Session Binding_Syntax_Theory

Theory Preliminaries

section ‹Preliminaries›


theory Preliminaries imports "HOL-Cardinals.Cardinals"
begin

text ‹This section discusses preliminaries on families of items (technically,
partial functions from a type of {\em indexes})
that we call {\em inputs} because they will be inputs to the binding operations.
For inputs, we define some monad-like lifting operators.
We also define simple infinitely branching trees (with no info attached
to the nodes and with branching given by partial functions from
indexes) -- these will be used as ``skeletons'' for terms, giving a size 
on which we can induct.
›

abbreviation regular where "regular  stable"
lemmas regular_UNION = stable_UNION


subsection ‹Trivia›


type_synonym 'a pair = "'a * 'a"

type_synonym 'a triple = "'a * 'a *'a"

type_synonym 'a rel = "'a pair set"


(* Selectors for triples *)

definition fst3 where "fst3 == fst"
definition snd3 where "snd3 == fst o snd"
definition trd3 where "trd3 == snd o snd"


lemma fst3_simp[simp]: "fst3 (a,b,c) = a"
unfolding fst3_def by simp


lemma snd3_simp[simp]: "snd3 (a,b,c) = b"
unfolding snd3_def by simp


lemma trd3_simp[simp]: "trd3 (a,b,c) = c"
unfolding trd3_def by simp


lemma fst3_snd3_trd3: "abc = (fst3 abc, snd3 abc, trd3 abc)"
unfolding fst3_def snd3_def trd3_def by auto


lemma fst3_snd3_trd3_rev[simp]:
"(fst3 abc, snd3 abc, trd3 abc) = abc"
using fst3_snd3_trd3[of abc] by simp


lemma map_id[simp]: "map id l = l"
unfolding id_def by simp


abbreviation max3 where
"max3 x y z == max (max x y) z"

lemmas map_id_cong = map_idI 
 
lemma ext2:
"(f  g) = ( x. f x  g x)"
using ext by auto

lemma not_equals_and_not_equals_not_in:
"(y  x  y  x'  phi) =
 (y  {x,x'}  phi)"
by simp


lemma mp2:
assumes "!! x y. phi x y  chi x y" and "phi x y"
shows "chi x y"
using assms by simp


lemma mp3:
assumes "!! x y z. phi x y z  chi x y z" and "phi x y z"
shows "chi x y z"
using assms by simp

lemma all_lt_Suc:
"( i < Suc n. phi i) = (( i < n. phi i)  phi n)"
using less_Suc_eq by auto

declare hd_map[simp]
lemmas tl_map[simp] = list.map_sel 
declare last_map[simp] 

lemma tl_last[simp]:
assumes "tl L  []"
shows "last (tl L) = last L"
using assms apply - by(induct L, auto)

lemma tl_last_hd:
assumes "L  []" and "tl L = []"
shows "last L = hd L"
using assms apply - by(induct L, auto)



subsection ‹Lexicographic induction›

definition lt2 where
"lt2 == less_than <*lex*> less_than"

definition lt3 where
"lt3 == less_than <*lex*> lt2"

lemma wf_lt2:
"wf lt2"
unfolding lt2_def by auto

lemma wf_lt3:
"wf lt3"
unfolding lt3_def by (auto simp add: wf_lt2)

lemma lt2[intro]:
"!! k1 k2 j1 j2. k1 < j1  ((k1,k2),(j1,j2))  lt2"
"!! k1 k2 j1 j2. k1  j1; k2 < j2  ((k1,k2),(j1,j2))  lt2"
unfolding lt2_def by auto

lemma lt3[intro]:
"!! k1 k2 k3 j1 j2 j3. k1 < j1  ((k1,k2,k3),(j1,j2,j3))  lt3"
"!! k1 k2 k3 j1 j2 j3. k1  j1; k2 < j2  ((k1,k2,k3),(j1,j2,j3))  lt3"
"!! k1 k2 k3 j1 j2 j3. k1  j1; k2  j2; k3 < j3  ((k1,k2,k3),(j1,j2,j3))  lt3"
unfolding lt3_def by auto

lemma measure_lex2_induct:
fixes h1 :: "'a1  nat" and h2 :: "'a2  nat"
assumes
"!! x1 x2.
  (!! y1 y2. h1 y1 < h1 x1  phi y1 y2);
   (!! y1 y2. h1 y1  h1 x1; h2 y2 < h2 x2  phi y1 y2)
   phi x1 x2"
shows "phi x1 x2"
proof-
  let ?chi = "%(n1,n2). ALL x1 x2. h1 x1 = n1  h2 x2 = n2  phi x1 x2"
  {fix n1 n2
   have "?chi (n1,n2)"
   apply(rule wf_induct[of lt2 ?chi]) using wf_lt2 assms by blast+
  }
  thus ?thesis by blast
qed

lemma measure_lex3_induct:
fixes h1 :: "'a1  nat" and h2 :: "'a2  nat" and h3 :: "'a3  nat"
assumes
"!! x1 x2 x3.
  (!! y1 y2 y3. h1 y1 < h1 x1  phi y1 y2 y3);
   (!! y1 y2 y3. h1 y1  h1 x1; h2 y2 < h2 x2  phi y1 y2 y3);
   (!! y1 y2 y3. h1 y1  h1 x1; h2 y2  h2 x2; h3 y3 < h3 x3  phi y1 y2 y3)
   phi x1 x2 x3"
shows "phi x1 x2 x3"
proof-
  let ?chi = "%(n1,n2,n3). ALL x1 x2 x3. h1 x1 = n1  h2 x2 = n2  h3 x3 = n3  phi x1 x2 x3"
  {fix n1 n2 n3
   have "?chi (n1,n2,n3)"
   apply(rule wf_induct[of lt3 ?chi]) using wf_lt3 assms by blast+
  }
  thus ?thesis by blast
qed


subsection ‹Inputs and lifting operators›

type_synonym ('index,'val)input = "'index  'val option"

definition
lift :: "('val1  'val2)  ('index,'val1)input  ('index,'val2)input"
where
"lift h inp == λi. case inp i of None  None
                                |Some v  Some (h v)"

definition
liftAll :: "('val  bool)  ('index,'val)input  bool"
where
"liftAll phi inp ==  i v. inp i = Some v  phi v"

definition
lift2 ::
"('val1'  'val1  'val2)  ('index,'val1')input  ('index,'val1)input  ('index,'val2)input"
where
"lift2 h inp' inp ==
 λi. case (inp' i, inp i) of
   (Some v',Some v)  Some (h v' v)
  |_  None"

definition
sameDom ::  "('index,'val1)input  ('index,'val2)input  bool"
where "sameDom inp1 inp2 ==  i. (inp1 i = None) = (inp2 i = None)"


definition
liftAll2 :: "('val1  'val2  bool)  ('index,'val1)input  ('index,'val2)input  bool"
where
"liftAll2 phi inp1 inp2 == ( i v1 v2. inp1 i = Some v1  inp2 i = Some v2  phi v1 v2)"

lemma lift_None: "(lift h inp i = None) = (inp i = None)"
unfolding lift_def by (cases "inp i", auto)

lemma lift_Some:
"( v. lift h inp i = Some v) = ( v'. inp i = Some v')"
using lift_None[of h inp i] by force

lemma lift_cong[fundef_cong]:
assumes " i v. inp i = Some v   h v = h' v"
shows "lift h inp = lift h' inp"
unfolding lift_def apply(rule ext)+
using assms by (case_tac "inp i", auto)

lemma lift_preserves_inj:
assumes "inj f"
shows "inj (lift f)"
unfolding inj_on_def apply auto proof(rule ext)
  fix inp inp' i assume *: "lift f inp = lift f inp'"
  show "inp i = inp' i"
  proof(cases "inp i")
    assume inp: "inp i = None"
    hence "lift f inp i = None" unfolding lift_def by simp
    hence "lift f inp' i = None" using * by simp
    hence "inp' i = None" by(auto simp add: lift_None)
    thus ?thesis using inp by simp
  next
    fix v assume inp: "inp i = Some v"
    hence "lift f inp i = Some (f v)" unfolding lift_def by simp
    hence "lift f inp' i = Some (f v)" using * by simp
    then obtain v' where inp': "inp' i = Some v'" and "f v' = f v"
    unfolding lift_def by(case_tac "inp' i", auto)
    hence "v = v'" using assms unfolding inj_on_def by simp
    thus ?thesis using inp inp' by simp
  qed
qed

lemma liftAll_cong[fundef_cong]:
assumes " i v. inp i = Some v  phi v = phi' v"
shows "liftAll phi inp = liftAll phi' inp"
unfolding liftAll_def apply((rule iff_allI)+) using assms by simp

lemma liftAll2_cong[fundef_cong]:
assumes " i v1 v2. inp1 i = Some v1; inp2 i = Some v2  phi v1 v2 = phi' v1 v2"
shows "liftAll2 phi inp1 inp2 = liftAll2 phi' inp1 inp2"
unfolding liftAll2_def apply((rule iff_allI)+) using assms by blast

lemma lift_ident: "lift (λv. v) inp = inp"
by(unfold lift_def, rule ext, case_tac "inp i", auto)

lemma lift_id[simp]:
"lift id inp = inp"
unfolding lift_def apply (rule ext) by(case_tac "inp i", auto)

lemma lift_comp: "lift g (lift f inp) = lift (g o f) inp"
by(unfold lift_def o_def, rule ext, case_tac "inp i", auto)

lemma liftAll_mono:
assumes " v. phi v  chi v" and "liftAll phi inp"
shows "liftAll chi inp"
using assms unfolding liftAll_def by blast

lemma liftAll_True: "liftAll (λv. True) inp"
unfolding liftAll_def by auto

lemma liftAll_lift_comp:  "liftAll phi (lift f inp) = liftAll (phi o f) inp"
unfolding liftAll_def o_def  
by (metis (mono_tags, lifting) lift_Some lift_def option.inject option.simps(5))

lemma liftAll_lift_ext:
"liftAll (λ x. f x = g x) inp = (lift f inp = lift g inp)"
unfolding lift_def liftAll_def 
by (auto simp: fun_eq_iff option.case_eq_if)  

lemma liftAll_and:
"liftAll (λ x. phi x  chi x) inp = (liftAll phi inp  liftAll chi inp)"
unfolding liftAll_def by blast

lemma liftAll_mp:
assumes "liftAll (λ v. phi v  chi v) inp" and "liftAll phi inp"
shows "liftAll chi inp"
using assms unfolding liftAll_def by auto

lemma sameDom_refl: "sameDom inp inp"
unfolding sameDom_def by auto

lemma sameDom_sym:
"sameDom inp inp' = sameDom inp' inp"
unfolding sameDom_def by auto

lemma sameDom_trans:
"sameDom inp inp'; sameDom inp' inp''  sameDom inp inp''"
unfolding sameDom_def by auto

lemma sameDom_lift1:
"sameDom inp (lift f inp)"
unfolding sameDom_def lift_def 
by (auto simp: option.case_eq_if) 

lemma sameDom_lift2:
"sameDom (lift f inp) inp"
unfolding sameDom_def lift_def
by (auto simp: option.case_eq_if)  

lemma sameDom_lift_simp1[simp]:
"sameDom inp (lift f inp') = sameDom inp inp'"
unfolding sameDom_def lift_def by (force simp: fun_eq_iff option.case_eq_if) 

lemma sameDom_lift_simp2[simp]:
"sameDom (lift f inp) inp' = sameDom inp inp'"
unfolding sameDom_def lift_def by (force simp: fun_eq_iff option.case_eq_if)

lemma lift_preserves_sameDom:
assumes "sameDom inp inp'"
shows "sameDom (lift f inp) (lift g inp')"
using assms unfolding sameDom_def lift_def 
by (force simp: fun_eq_iff option.case_eq_if)
 
definition comp2 ::
"('b1  'b2  'c)  ('a1  'b1)  ('a2  'b2)  ('a1  'a2  'c)"
("_ o2 '(_,_')" 55)
where "h o2 (f,g) == λ x y. h (f x) (g y)"

lemma comp2_simp[simp]:
"(h o2 (f,g)) x y = h (f x) (g y)"
unfolding comp2_def by simp

lemma comp2_comp:
"((h o2 (f,g)) o2 (f',g')) = (h o2 (f o f', g o g'))"
unfolding comp_def[abs_def] comp2_def[abs_def] by auto

lemma liftAll_imp_liftAll2:
assumes "liftAll (λv.  v'. phi v v') inp"
shows "liftAll2 phi inp inp'"
using assms unfolding liftAll_def liftAll2_def by auto

lemma liftAll2_mono:
assumes " v v'. phi v v'  chi v v'" and "liftAll2 phi inp inp'"
shows "liftAll2 chi inp inp'"
using assms unfolding liftAll2_def by blast

lemma liftAll2_True: "liftAll2 (λ v v'. True) inp inp'"
unfolding liftAll2_def by auto

lemma liftAll2_lift_comp2:
"liftAll2 phi (lift f1 inp1) (lift f2 inp2) =
 liftAll2 (phi o2 (f1,f2)) inp1 inp2"
unfolding liftAll2_def lift_def 
by (auto simp: fun_eq_iff option.case_eq_if)
 
lemma lift_imp_sameDom:
"lift f inp = lift f inp'  sameDom inp inp'"
unfolding lift_def sameDom_def
by (force simp: fun_eq_iff option.case_eq_if split: if_splits)
 
lemma lift_lift2:
"lift f (lift2 g inp' inp) =
 lift2 (λ v' v. f (g v' v)) inp' inp"
unfolding lift_def lift2_def 
by (force simp: option.case_eq_if split: if_splits) 

lemma lift2_left[simp]:
assumes "sameDom inp' inp"
shows "lift2 (λ v' v. v') inp' inp = inp'"
using assms unfolding sameDom_def lift2_def 
by (simp add: fun_eq_iff option.case_eq_if) metis
 
lemma lift2_right[simp]:
assumes "sameDom inp' inp"
shows "lift2 (λ v' v. v) inp' inp = inp"
using assms unfolding sameDom_def lift2_def 
by (simp add: fun_eq_iff option.case_eq_if)  

lemma lift2_preserves_sameDom:
assumes "sameDom inp' inp1'" and "sameDom inp inp1"
shows "sameDom (lift2 f inp' inp) (lift2 g inp1' inp1)"
using assms unfolding sameDom_def lift2_def 
by (simp add: fun_eq_iff option.case_eq_if)  

lemma sameDom_lift2_1:
assumes "sameDom inp' inp"
shows
"sameDom inp' (lift2 f inp' inp) 
 sameDom inp (lift2 f inp' inp)"
using assms unfolding sameDom_def lift2_def 
by (simp add: fun_eq_iff option.case_eq_if)  

lemma sameDom_lift2_2:
assumes "sameDom inp' inp"
shows
"sameDom (lift2 f inp' inp) inp' 
 sameDom (lift2 f inp' inp) inp"
using assms unfolding sameDom_def lift2_def 
by (simp add: fun_eq_iff option.case_eq_if)  

lemma sameDom_lift2_simp1[simp]:
assumes "sameDom inp1' inp1"
shows "sameDom inp (lift2 f inp1' inp1) = sameDom inp inp1'"
using assms unfolding sameDom_def lift2_def 
by (simp add: fun_eq_iff option.case_eq_if) (metis not_Some_eq)

lemma sameDom_lift2_simp2[simp]:
assumes "sameDom inp' inp"
shows "sameDom (lift2 f inp' inp) inp1 = sameDom inp' inp1"
using assms unfolding sameDom_def lift2_def 
by (simp add: fun_eq_iff option.case_eq_if) (metis not_Some_eq)

lemma liftAll2_lift_ext:
"(sameDom inp inp'  liftAll2 (λ v v'. f v = f v') inp inp') =
 (lift f inp = lift f inp')"
unfolding sameDom_def lift_def liftAll2_def 
by (force simp add: fun_eq_iff option.case_eq_if) 

lemma liftAll2_and:
"liftAll2 (λ v v'. phi v v'  chi v v') inp inp' =
(liftAll2 phi inp inp'  liftAll2 chi inp inp')"
unfolding liftAll2_def by force

lemma liftAll2_mp:
assumes "liftAll2 (λ v v'. phi v v'  chi v v') inp inp'" and "liftAll2 phi inp inp'"
shows "liftAll2 chi inp inp'"
using assms unfolding liftAll2_def by auto

lemma sameDom_and_liftAll2_iff:
"(sameDom inp inp'  liftAll2 phi inp inp') =
 ( i. (inp i = None  inp' i = None) 
         ( v v'. inp i = Some v  inp' i = Some v'  phi v v'))"
unfolding sameDom_def liftAll2_def 
apply (auto simp add: fun_eq_iff option.case_eq_if) 
using option.sel by fastforce

subsection ‹Doubly infinitely-branching trees›

text "These simple infinitary trees shall be used for measuring the sizes
  of possibly infinitary terms."

datatype ('index,'bindex)tree =
  Branch "('index,('index,'bindex)tree) input" "('bindex,('index,'bindex)tree) input"


(* The natural induction principle for (infinitary) trees:  *)
lemma tree_induct:
fixes phi::"('index,'bindex)tree  bool" and T::"('index,'bindex)tree"
assumes
  " inp binp. liftAll phi inp; liftAll phi binp  phi (Branch inp binp)"
shows "phi T"
using assms unfolding liftAll_def  
by (induct T) (simp, metis rangeI) 

definition treeLess :: "('index,'bindex)tree rel"
where
"treeLess ==
 {(T,T').  inp binp i j. T' = Branch inp binp  (inp i = Some T  binp j = Some T)}"

lemma treeLess_induct:
fixes phi::"('index,'bindex)tree  bool" and
      T::"('index,'bindex)tree"
assumes " T'. ( T. (T,T')  treeLess  phi T)  phi T'"
shows "phi T"
apply(induct rule: tree_induct)
using assms unfolding treeLess_def liftAll_def  
by simp (metis tree.inject) 

lemma treeLess_wf: "wf treeLess"
unfolding wf_def using treeLess_induct by blast


subsection ‹Ordering›

lemma Least_Max:
assumes phi: "phi (n::nat)" and fin: "finite {n. phi n}"
shows "(LEAST m.  n. phi n  n  m) =
       Max {n. phi n}" 
using assms Max_in by (intro Least_equality) auto


end

Theory QuasiTerms_Swap_Fresh

section ‹Quasi-Terms with Swapping and Freshness›

theory QuasiTerms_Swap_Fresh imports Preliminaries 
begin

text‹
This section defines and studies the (totally free) datatype of quasi-terms
and the notions of freshness and
swapping variables for them.
``Quasi" refers to the fact that these items are not (yet) factored to alpha-equivalence.
 We shall later call ``terms" those alpha-equivalence classes.›

subsection ‹The datatype of quasi-terms with bindings›

datatype
('index,'bindex,'varSort,'var,'opSym)qTerm =
   qVar 'varSort 'var
  |qOp 'opSym "('index, (('index,'bindex,'varSort,'var,'opSym)qTerm))input"
              "('bindex, (('index,'bindex,'varSort,'var,'opSym)qAbs)) input"
and
('index,'bindex,'varSort,'var,'opSym)qAbs =
  qAbs 'varSort 'var "('index,'bindex,'varSort,'var,'opSym)qTerm"

text‹Above:
\begin{itemize}
\item ``Var" stands for ``variable injection"
\item ``Op" stands for ``operation"
\item ``opSym" stands for ``operation symbol"
\item ``q" stands for ``quasi"
\item ``Abs" stands for ``abstraction"
\end{itemize}

Thus, a quasi-term is either (an injection of) a variable, or an operation symbol applied
to a term-input and an abstraction-input
(where, for any type $T$, $T$-inputs are partial
maps from indexes to $T$. A quasi-abstraction is
essentially a pair (variable,quasi-term).
›

type_synonym ('index,'bindex,'varSort,'var,'opSym)qTermItem =
"('index,'bindex,'varSort,'var,'opSym)qTerm +
 ('index,'bindex,'varSort,'var,'opSym)qAbs"

abbreviation termIn ::
"('index,'bindex,'varSort,'var,'opSym)qTerm  ('index,'bindex,'varSort,'var,'opSym)qTermItem"
where "termIn X == Inl X"

abbreviation absIn ::
"('index,'bindex,'varSort,'var,'opSym)qAbs  ('index,'bindex,'varSort,'var,'opSym)qTermItem"
where "absIn A == Inr A"

subsection ‹Induction principles›

definition qTermLess :: "('index,'bindex,'varSort,'var,'opSym)qTermItem rel"
where
"qTermLess == {(termIn X, termIn(qOp delta inp binp))| X delta inp binp i. inp i = Some X} 
              {(absIn A, termIn(qOp delta inp binp))| A delta inp binp i. binp i = Some A} 
              {(termIn X, absIn (qAbs xs x X))| X xs x. True}"

text‹This induction will be used only temporarily, until we
   get a better one, involving swapping:›

lemma qTerm_rawInduct[case_names Var Op Abs]:
fixes X :: "('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A :: "('index,'bindex,'varSort,'var,'opSym)qAbs" and phi phiAbs
assumes
  Var: " xs x. phi (qVar xs x)" and
  Op: " delta inp binp. liftAll phi inp; liftAll phiAbs binp  phi (qOp delta inp binp)" and
  Abs: " xs x X. phi X  phiAbs (qAbs xs x X)"
shows "phi X  phiAbs A"
by (induct rule: qTerm_qAbs.induct)
   (fastforce intro!: Var Op Abs rangeI simp: liftAll_def)+

lemma qTermLess_wf: "wf qTermLess" 
unfolding wf_def proof safe
  fix chi item
  assume *: "item. (item'. (item', item)  qTermLess  chi item')  chi item"
  show "chi item"
  proof-
    {fix X A
     have "chi (termIn X)  chi (absIn A)"
     apply(induct rule: qTerm_rawInduct)
     using * unfolding qTermLess_def liftAll_def by blast+
    }
    thus ?thesis by(cases item) auto
  qed
qed

lemma qTermLessPlus_wf: "wf (qTermLess ^+)"
using qTermLess_wf wf_trancl by auto

text‹The skeleton of a quasi-term item -- this is the generalization
   of the size function from the case of finitary syntax.
   We use the skeleton later for proving correct various recursive function definitions, notably that of ``alpha".›

function
qSkel :: "('index,'bindex,'varSort,'var,'opSym)qTerm  ('index,'bindex)tree"
and
qSkelAbs :: "('index,'bindex,'varSort,'var,'opSym)qAbs  ('index,'bindex)tree"
where
"qSkel (qVar xs x) = Branch (λi. None) (λi. None)"
|
"qSkel (qOp delta inp binp) = Branch (lift qSkel inp) (lift qSkelAbs binp)"
|
"qSkelAbs (qAbs xs x X) = Branch (λi. Some(qSkel X)) (λi. None)"
by(pat_completeness, auto)
termination by(relation qTermLess, simp add: qTermLess_wf, auto simp add: qTermLess_def)

text‹Next is a template for generating induction principles whenever we come up
  with relation on terms included in the kernel of the skeleton operator.›

lemma qTerm_templateInduct[case_names Var Op Abs]:
fixes X :: "('index,'bindex,'varSort,'var,'opSym)qTerm"
and A :: "('index,'bindex,'varSort,'var,'opSym)qAbs"
and phi phiAbs and rel
assumes
REL: " X Y. (X,Y)  rel  qSkel Y = qSkel X" and
Var: " xs x. phi (qVar xs x)" and
Op: " delta inp binp. liftAll phi inp; liftAll phiAbs binp
                        phi (qOp delta inp binp)" and
Abs: " xs x X. ( Y. (X,Y)  rel  phi Y)  phiAbs (qAbs xs x X)"
shows "phi X  phiAbs A" 
proof-
  {fix T
   have " X A. (T = qSkel X  phi X)  (T = qSkelAbs A  phiAbs A)"
   proof(induct rule: treeLess_induct)
     case (1 T')
     show ?case apply safe  
      subgoal for X _ 
      using assms 1 unfolding treeLess_def liftAll_def 
      by (cases X) (auto simp add: lift_def, metis option.simps(5))
     subgoal for _ A apply (cases A)
     using assms 1 unfolding treeLess_def by simp .       
   qed
  }
  thus ?thesis by blast
qed

text‹A modification of the canonical immediate-subterm
relation on quasi-terms, that takes into account a relation assumed included in the skeleton kernel.›

definition qTermLess_modulo ::
"('index,'bindex,'varSort,'var,'opSym)qTerm rel 
 ('index,'bindex,'varSort,'var,'opSym)qTermItem rel"
where
"qTermLess_modulo rel ==
 {(termIn X, termIn(qOp delta inp binp))| X delta inp binp i. inp i = Some X} 
 {(absIn A, termIn(qOp delta inp binp))| A delta inp binp j. binp j = Some A} 
 {(termIn Y, absIn (qAbs xs x X))| X Y xs x. (X,Y)  rel}"

lemma qTermLess_modulo_wf:
fixes rel::"('index,'bindex,'varSort,'var,'opSym)qTerm rel"
assumes " X Y. (X,Y)  rel  qSkel Y = qSkel X"
shows "wf (qTermLess_modulo rel)"
proof(unfold wf_def, auto)
  fix chi item
  assume *:
  "item. (item'. (item', item)  qTermLess_modulo rel   chi item')
            chi item"
  show "chi item"
  proof-
    obtain phi where phi_def: "phi = (λ X. chi (termIn X))" by blast
    obtain phiAbs where phiAbs_def: "phiAbs = (λ A. chi (absIn A))" by blast
    {fix X A
     have "chi (termIn X)  chi (absIn A)"
     apply(induct rule: qTerm_templateInduct[of rel])
     using * assms unfolding qTermLess_modulo_def liftAll_def by blast+
    }
    thus ?thesis unfolding phi_def phiAbs_def
    by(cases item, auto)
  qed
qed

subsection ‹Swap and substitution on variables›

definition sw :: "'varSort  'var  'var  'varSort  'var  'var"
where
"sw ys y1 y2 xs x ==
 if ys = xs then if x = y1 then y2
            else if x = y2 then y1
                           else x
 else x"

abbreviation sw_abbrev :: "'var  'varSort  'var  'var  'varSort  'var"
("_ @_[_  _]'__" 200)
where "(x @xs[y1  y2]_ys) == sw ys y1 y2 xs x"

definition sb :: "'varSort  'var  'var  'varSort  'var  'var"
where
"sb ys y1 y2 xs x ==
 if ys = xs then if x = y2 then y1
                           else x
 else x"

abbreviation sb_abbrev :: "'var  'varSort  'var  'var  'varSort  'var"
("_ @_[_ '/ _]'__" 200)
where "(x @xs[y1 / y2]_ys) == sb ys y1 y2 xs x"

theorem sw_simps1[simp]: "(x @xs[x  y]_xs) = y"
unfolding sw_def by simp

theorem sw_simps2[simp]: "(x @xs[y  x]_xs) = y"
unfolding sw_def by simp

theorem sw_simps3[simp]:
"(zs  xs  x  {z1,z2})  (x @xs[z1  z2]_zs) = x"
unfolding sw_def by simp

lemmas sw_simps = sw_simps1 sw_simps2 sw_simps3

theorem sw_ident[simp]: "(x @xs[y  y]_ys) = x"
unfolding sw_def by auto

theorem sw_compose:
"((z @zs[x  y]_xs) @zs[x'  y']_xs') =
 ((z @zs[x'  y']_xs') @zs[(x @xs[x'  y']_xs')  (y @xs[x'  y']_xs')]_xs)"
by(unfold sw_def, auto)

theorem sw_commute:
assumes "zs  zs'  {x,y} Int {x',y'} = {}"
shows "((u @us[x  y]_zs) @us[x'  y']_zs') = ((u @us[x'  y']_zs') @us[x  y]_zs)"
using assms by(unfold sw_def, auto)

theorem sw_involutive[simp]:
"((z @zs[x  y]_xs) @zs[x  y]_xs) = z"
by(unfold sw_def, auto)

theorem sw_inj[simp]:
"((z @zs[x  y]_xs) = (z' @zs[x  y]_xs)) = (z = z')"
by (simp add: sw_def) 

lemma sw_preserves_mship[simp]:
assumes "{y1,y2}  Var ys"
shows "((x @xs[y1  y2]_ys)  Var xs) = (x  Var xs)"
using assms unfolding sw_def by auto

theorem sw_sym:
"(z @zs[x  y]_xs) = (z @zs[y  x]_xs)"
by (unfold sw_def) auto

theorem sw_involutive2[simp]:
"((z @zs[x  y]_xs) @zs[y  x]_xs) = z"
by (unfold sw_def) auto

theorem sw_trans:
"us  zs  u  {y,z} 
 ((u @us[y  x]_zs) @us[z  y]_zs) = (u @us[z  x]_zs)"
by (unfold sw_def) auto

lemmas sw_otherSimps =
sw_ident sw_involutive sw_inj sw_preserves_mship sw_involutive2

theorem sb_simps1[simp]: "(x @xs[y / x]_xs) = y"
unfolding sb_def by simp

theorem sb_simps2[simp]:
"(zs  xs  z2  x)  (x @xs[z1 / z2]_zs) = x"
unfolding sb_def by auto

lemmas sb_simps = sb_simps1 sb_simps2

theorem sb_ident[simp]: "(x @xs[y / y]_ys) = x"
unfolding sb_def by auto

theorem sb_compose1:
"((z @zs[y1 / x]_xs) @zs[y2 / x]_xs) = (z @zs[(y1 @xs[y2 / x]_xs) / x]_xs)"
by(unfold sb_def, auto)

theorem sb_compose2:
"ys  xs  (x2  {y1,y2}) 
 ((z @zs[x1 / x2]_xs) @zs[y1 / y2]_ys) =
 ((z @zs[y1 / y2]_ys) @zs[(x1 @xs[y1 / y2]_ys) / x2]_xs)"
by (unfold sb_def) auto

theorem sb_commute:
assumes "zs  zs'  {x,y} Int {x',y'} = {}"
shows "((u @us[x / y]_zs) @us[x' / y']_zs') = ((u @us[x' / y']_zs') @us[x / y]_zs)"
using assms by (unfold sb_def) auto

theorem sb_idem[simp]:
"((z @zs[x / y]_xs) @zs[x / y]_xs) = (z @zs[x / y]_xs)"
by (unfold sb_def) auto

lemma sb_preserves_mship[simp]:
assumes "{y1,y2}  Var ys"
shows "((x @xs[y1 / y2]_ys)  Var xs) = (x  Var xs)"
using assms by (unfold sb_def) auto

theorem sb_trans:
"us  zs  u  y 
 ((u @us[y / x]_zs) @us[z / y]_zs) = (u @us[z / x]_zs)"
by (unfold sb_def) auto

lemmas sb_otherSimps =
sb_ident sb_idem sb_preserves_mship

subsection ‹The swapping and freshness operators›

text ‹For establishing the preliminary results quickly, we use both the notion of
binding-sensitive freshness (operator ``qFresh")
       and that of ``absolute" freshness, ignoring bindings (operator ``qAFresh").  Later,
       for alpha-equivalence classes, ``qAFresh" will not make sense.›

definition
aux_qSwap_ignoreFirst3 ::
"'varSort * 'var * 'var * ('index,'bindex,'varSort,'var,'opSym)qTerm +
 'varSort * 'var * 'var * ('index,'bindex,'varSort,'var,'opSym)qAbs 
 ('index,'bindex,'varSort,'var,'opSym)qTermItem"
where
"aux_qSwap_ignoreFirst3 K =
 (case K of Inl(zs,x,y,X)  termIn X
           |Inr(zs,x,y,A)  absIn A)"

lemma qTermLess_ingoreFirst3_wf:
"wf(inv_image qTermLess aux_qSwap_ignoreFirst3)"
using qTermLess_wf wf_inv_image by auto

function
qSwap :: "'varSort  'var  'var  ('index,'bindex,'varSort,'var,'opSym)qTerm 
          ('index,'bindex,'varSort,'var,'opSym)qTerm"
and
qSwapAbs :: "'varSort  'var  'var  ('index,'bindex,'varSort,'var,'opSym)qAbs 
             ('index,'bindex,'varSort,'var,'opSym)qAbs"
where
"qSwap zs x y (qVar zs' z) = qVar zs' (z @zs'[x  y]_zs)"
|
"qSwap zs x y (qOp delta inp binp) =
 qOp delta (lift (qSwap zs x y) inp) (lift (qSwapAbs zs x y) binp)"
|
"qSwapAbs zs x y (qAbs zs' z X) = qAbs zs' (z @zs'[x  y]_zs) (qSwap zs x y X)"
by(pat_completeness, auto)
termination
by(relation "inv_image qTermLess aux_qSwap_ignoreFirst3",
   simp add: qTermLess_ingoreFirst3_wf,
   auto simp add: qTermLess_def aux_qSwap_ignoreFirst3_def)

lemmas qSwapAll_simps = qSwap.simps qSwapAbs.simps

abbreviation qSwap_abbrev ::
  "('index,'bindex,'varSort,'var,'opSym)qTerm  'var  'var  'varSort 
   ('index,'bindex,'varSort,'var,'opSym)qTerm" ("_ #[[_  _]]'__" 200)
where "(X #[[z1  z2]]_zs) == qSwap zs z1 z2 X"

abbreviation qSwapAbs_abbrev ::
  "('index,'bindex,'varSort,'var,'opSym)qAbs  'var  'var  'varSort 
   ('index,'bindex,'varSort,'var,'opSym)qAbs" ("_ $[[_  _]]'__" 200)
where "(A $[[z1  z2]]_zs) == qSwapAbs zs z1 z2 A"

definition
aux_qFresh_ignoreFirst2 ::
"'varSort * 'var * ('index,'bindex,'varSort,'var,'opSym)qTerm +
 'varSort * 'var * ('index,'bindex,'varSort,'var,'opSym)qAbs 
 ('index,'bindex,'varSort,'var,'opSym)qTermItem"
where
"aux_qFresh_ignoreFirst2 K =
 (case K of Inl(zs,x,X)  termIn X
           |Inr (zs,x,A)  absIn A)"

lemma qTermLess_ingoreFirst2_wf: "wf(inv_image qTermLess aux_qFresh_ignoreFirst2)"
using qTermLess_wf wf_inv_image by auto

text‹The quasi absolutely-fresh predicate:
  (note that this is not an oxymoron: ``quasi" refers
   to being an operator on quasi-terms, and not on
terms, i.e., on alpha-equivalence  classes;
   ``absolutely'' refers to not ignoring bindings in the notion of freshness,
and thus counting absolutely all the variables.›

function
qAFresh :: "'varSort  'var  ('index,'bindex,'varSort,'var,'opSym)qTerm  bool"
and
qAFreshAbs :: "'varSort  'var  ('index,'bindex,'varSort,'var,'opSym)qAbs  bool"
where
"qAFresh xs x (qVar ys y) = (xs  ys  x  y)"
|
"qAFresh xs x (qOp delta inp binp) =
 (liftAll (qAFresh xs x) inp  liftAll (qAFreshAbs xs x) binp)"
|
"qAFreshAbs xs x (qAbs ys y X) = ((xs  ys  x  y)  qAFresh xs x X)"
by(pat_completeness, auto)
termination
by(relation "inv_image qTermLess aux_qFresh_ignoreFirst2",
   simp add: qTermLess_ingoreFirst2_wf,
   auto simp add: qTermLess_def aux_qFresh_ignoreFirst2_def)

lemmas qAFreshAll_simps = qAFresh.simps qAFreshAbs.simps

text‹The next is standard freshness -- note that its definition differs from that
of absolute freshness only at the clause for abstractions.›

function
qFresh :: "'varSort  'var  ('index,'bindex,'varSort,'var,'opSym)qTerm  bool"
and
qFreshAbs :: "'varSort  'var  ('index,'bindex,'varSort,'var,'opSym)qAbs  bool"
where
"qFresh xs x (qVar ys y) = (xs  ys  x  y)"
|
"qFresh xs x (qOp delta inp binp) =
 (liftAll (qFresh xs x) inp  liftAll (qFreshAbs xs x) binp)"
|
"qFreshAbs xs x (qAbs ys y X) = ((xs = ys  x = y)  qFresh xs x X)"
by(pat_completeness, auto)
termination
by(relation "inv_image qTermLess aux_qFresh_ignoreFirst2",
   simp add: qTermLess_ingoreFirst2_wf,
   auto simp add: qTermLess_def aux_qFresh_ignoreFirst2_def)

lemmas qFreshAll_simps = qFresh.simps qFreshAbs.simps

subsection ‹Compositional properties of swapping›

lemma qSwapAll_ident:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs"
    shows "(X #[[x  x]]_zs) = X  (A $[[x  x]]_zs) = A"
  by (induct rule: qTerm_rawInduct)
     (auto simp add: liftAll_def lift_cong lift_ident)

corollary qSwap_ident[simp]: "(X #[[x  x]]_zs) = X"
by(simp add: qSwapAll_ident)

lemma qSwapAll_compose:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm"  and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs" and zs x y x' y'
shows
"((X #[[x  y]]_zs) #[[x'  y']]_zs') =
 ((X #[[x'  y']]_zs') #[[(x @zs[x'  y']_zs')  (y @zs[x'  y']_zs')]]_zs)

 ((A $[[x  y]]_zs) $[[x'  y']]_zs') =
 ((A $[[x'  y']]_zs') $[[(x @zs[x'  y']_zs')  (y @zs[x'  y']_zs')]]_zs)"
proof(induct rule: qTerm_rawInduct[of _ _ X A])
  case (Op delta inp binp)
  then show ?case by (auto intro!: lift_cong simp: liftAll_def lift_comp)
qed (auto simp add: sw_def sw_compose)
  
corollary qSwap_compose:
"((X #[[x  y]]_zs) #[[x'  y']]_zs') =
 ((X #[[x'  y']]_zs') #[[(x @zs[x'  y']_zs')  (y @zs[x'  y']_zs')]]_zs)"
by (meson qSwapAll_compose)

lemma qSwap_commute:
assumes "zs  zs'  {x,y} Int {x',y'} = {}"
shows "((X #[[x  y]]_zs) #[[x'  y']]_zs') = ((X #[[x'  y']]_zs') #[[x  y]]_zs)"
by (metis assms disjoint_insert(1) qSwapAll_compose sw_simps3)

lemma qSwapAll_involutive:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs" and zs x y
shows "((X #[[x  y]]_zs) #[[x  y]]_zs) = X 
       ((A $[[x  y]]_zs) $[[x  y]]_zs) = A"
proof(induct rule: qTerm_rawInduct[of _ _ X A])
  case (Op delta inp binp)
  then show ?case 
    unfolding qSwapAll_simps(2) liftAll_lift_ext
    lift_comp o_def
    by (simp add: lift_ident)
qed(auto)
  

corollary qSwap_involutive[simp]:
"((X #[[x  y]]_zs) #[[x  y]]_zs) = X"
by(simp add: qSwapAll_involutive)

lemma qSwapAll_sym:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs" and zs x y
shows "(X #[[x  y]]_zs) = (X #[[y  x]]_zs) 
       (A $[[x  y]]_zs) = (A $[[y  x]]_zs)"
by (induct rule: qTerm_rawInduct[of _ _ X A])  
   (auto simp: sw_sym lift_comp liftAll_lift_ext)

corollary qSwap_sym:
"(X #[[x  y]]_zs) = (X #[[y  x]]_zs)"
by(simp add: qSwapAll_sym)

lemma qAFreshAll_qSwapAll_id:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs" and zs z1 z2
shows "(qAFresh zs z1 X  qAFresh zs z2 X   (X #[[z1  z2]]_zs) = X) 
       (qAFreshAbs zs z1 A  qAFreshAbs zs z2 A   (A $[[z1  z2]]_zs) = A)"
by (induct rule: qTerm_rawInduct[of _ _ X A])
   (auto intro!: ext simp: liftAll_def lift_def option.case_eq_if)

corollary qAFresh_qSwap_id[simp]:
"qAFresh zs z1 X; qAFresh zs z2 X   (X #[[z1  z2]]_zs) = X"
by(simp add: qAFreshAll_qSwapAll_id)

lemma qAFreshAll_qSwapAll_compose:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs"and zs x y z
shows  "(qAFresh zs y X  qAFresh zs z X 
         ((X #[[y  x]]_zs) #[[z  y]]_zs) = (X #[[z  x]]_zs)) 
        (qAFreshAbs zs y A  qAFreshAbs zs z A 
         ((A $[[y  x]]_zs) $[[z  y]]_zs) = (A $[[z  x]]_zs))"
by (induct rule: qTerm_rawInduct[of _ _ X A])
   (auto intro!: ext simp: sw_trans lift_comp lift_def liftAll_def option.case_eq_if)
   
corollary qAFresh_qSwap_compose:
"qAFresh zs y X; qAFresh zs z X 
 ((X #[[y  x]]_zs) #[[z  y]]_zs) = (X #[[z  x]]_zs)"
by(simp add: qAFreshAll_qSwapAll_compose)

subsection ‹Induction and well-foundedness modulo swapping›

lemma qSkel_qSwapAll:
fixes  X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
       A::"('index,'bindex,'varSort,'var,'opSym)qAbs" and x y zs
shows "qSkel(X #[[x  y]]_zs) = qSkel X 
       qSkelAbs(A $[[x  y]]_zs) = qSkelAbs A"
proof(induct rule: qTerm_rawInduct[of _ _ X A])
  case (Op delta inp binp)
  then show ?case 
    unfolding qSwapAll_simps(2) liftAll_lift_ext qSkel.simps(2)
    lift_comp comp_apply by simp
qed auto

corollary qSkel_qSwap: "qSkel(X #[[x  y]]_zs) = qSkel X"
by(simp add: qSkel_qSwapAll)

text‹
  For induction modulo swapping, one may wish to swap not just once,
   but several times at the
   induction hypothesis (an example of this will be the proof of compatibility
   of ``qSwap" with alpha) -- for this, we introduce the following relation
  (the suffix ``Raw" signifies the fact that the involved variables are
  not required to be well-sorted):›

inductive_set qSwapped :: "('index,'bindex,'varSort,'var,'opSym)qTerm rel"
where
Refl: "(X,X)  qSwapped"
|
Trans: "(X,Y)  qSwapped; (Y,Z)  qSwapped  (X,Z)  qSwapped"
|
Swap: "(X,Y)  qSwapped  (X, Y #[[x  y]]_zs)  qSwapped"

lemmas qSwapped_Clauses = qSwapped.Refl qSwapped.Trans qSwapped.Swap

lemma qSwap_qSwapped: "(X, X #[[x  y]]_zs): qSwapped"
by (auto simp add: qSwapped_Clauses)

lemma qSwapped_qSkel:
"(X,Y)  qSwapped   qSkel Y = qSkel X"
by(erule qSwapped.induct, auto simp add: qSkel_qSwap)

text‹The following is henceforth our main induction principle for quasi-terms.  At the
 clause for abstractions, the user may choose among the two
 induction hypotheses (IHs):
 \\-(1) IH for all swapped terms
 \\-(2) IH for all terms with the same skeleton.

The user may choose only one of the above, and ignore the others, but may of course also
assume both.  (2) is stronger than (1),
but we offer both of them for convenience in proofs.
Most of the times, (1) will be the most convenient.›

lemma qTerm_induct[case_names Var Op Abs]:
fixes X :: "('index,'bindex,'varSort,'var,'opSym)qTerm"
and A :: "('index,'bindex,'varSort,'var,'opSym)qAbs"  and phi phiAbs
assumes
  Var: " xs x. phi (qVar xs x)" and
  Op: " delta inp binp. liftAll phi inp; liftAll phiAbs binp
                          phi (qOp delta inp binp)" and
  Abs: " xs x X.  Y. (X,Y)  qSwapped  phi Y;
                     Y. qSkel Y = qSkel X  phi Y
                     phiAbs (qAbs xs x X)"
shows "phi X  phiAbs A"
  by (induct rule: qTerm_templateInduct[of "qSwapped  {(X,Y). qSkel Y = qSkel X}"], 
      auto simp add: qSwapped_qSkel assms)


text‹The following relation will be needed for proving alpha-equivalence well-defined:›

definition qTermQSwappedLess :: "('index,'bindex,'varSort,'var,'opSym)qTermItem rel"
where "qTermQSwappedLess = qTermLess_modulo qSwapped"

lemma qTermQSwappedLess_wf: "wf qTermQSwappedLess"
unfolding qTermQSwappedLess_def
using qSwapped_qSkel qTermLess_modulo_wf[of qSwapped] by blast


subsection‹More properties connecting swapping and freshness›

lemma qSwap_3commute:
assumes *: "qAFresh ys y X" and **: "qAFresh ys y0 X"
and ***: "ys  zs  y0  {z1,z2}"
shows "((X #[[z1  z2]]_zs) #[[y0  x @ys[z1  z2]_zs]]_ys) =
       (((X #[[y  x]]_ys) #[[y0  y]]_ys) #[[z1  z2]]_zs)"
proof-
  have "y0 = (y0 @ys[z1  z2]_zs)" using *** unfolding sw_def by auto
  hence "((X #[[z1  z2]]_zs) #[[y0  x @ys[z1  z2]_zs]]_ys) =
         ((X #[[y0  x]]_ys) #[[z1  z2]]_zs)"
  by(simp add: qSwap_compose[of _ z1])
  also have "((X #[[y0  x]]_ys) #[[z1  z2]]_zs) =
             (((X #[[y  x]]_ys) #[[y0  y]]_ys) #[[z1  z2]]_zs)"
  using * ** by (simp add: qAFresh_qSwap_compose)
  finally show ?thesis .
qed

lemma qAFreshAll_imp_qFreshAll:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs" and xs x
shows "(qAFresh xs x X  qFresh xs x X) 
       (qAFreshAbs xs x A  qFreshAbs xs x A)"
by(induct rule: qTerm_rawInduct, auto simp add: liftAll_def)

corollary qAFresh_imp_qFresh:
"qAFresh xs x X  qFresh xs x X"
by(simp add: qAFreshAll_imp_qFreshAll)

lemma qSwapAll_preserves_qAFreshAll:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs" and ys y zs z1 z2
shows
"(qAFresh ys (y @ys[z1  z2]_zs) (X #[[z1  z2]]_zs) = qAFresh ys y X) 
 (qAFreshAbs ys (y @ys[z1  z2]_zs) (A $[[z1  z2]]_zs) = qAFreshAbs ys y A)"
proof(induct rule: qTerm_rawInduct[of _ _ X A])
  case (Op delta inp binp)
  then show ?case 
    unfolding qAFreshAll_simps(2) qSwapAll_simps(2) liftAll_lift_comp o_def 
    unfolding liftAll_def by presburger
qed(auto simp add: sw_def)

corollary qSwap_preserves_qAFresh[simp]:
"(qAFresh ys (y @ys[z1  z2]_zs) (X #[[z1  z2]]_zs) = qAFresh ys y X)"
by(simp add: qSwapAll_preserves_qAFreshAll)

lemma qSwap_preserves_qAFresh_distinct:
assumes "ys  zs  y  {z1,z2}"
shows "qAFresh ys y (X #[[z1  z2]]_zs) = qAFresh ys y X"
proof-
  have "y = (y @ys[z1  z2]_zs)" using assms unfolding sw_def by auto
  thus ?thesis using qSwap_preserves_qAFresh[of ys zs z1 z2 y] by auto
qed

lemma qAFresh_qSwap_exchange1:
"qAFresh zs z2 (X #[[z1  z2]]_zs) = qAFresh zs z1 X"
proof-
  have "z2 = (z1 @zs[z1  z2]_zs)" unfolding sw_def by auto
  thus ?thesis using qSwap_preserves_qAFresh[of zs zs z1 z2 z1 X] by auto
qed

lemma qAFresh_qSwap_exchange2:
"qAFresh zs z2 (X #[[z2  z1]]_zs) = qAFresh zs z1 X"
by(auto simp add: qAFresh_qSwap_exchange1 qSwap_sym)

lemma qSwapAll_preserves_qFreshAll:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs" and ys y zs z1 z2
shows
"(qFresh ys (y @ys[z1  z2]_zs) (X #[[z1  z2]]_zs) = qFresh ys y X) 
 (qFreshAbs ys (y @ys[z1  z2]_zs) (A $[[z1  z2]]_zs) = qFreshAbs ys y A)"
proof(induct rule: qTerm_rawInduct[of _ _ X A])
  case (Op delta inp binp)
  then show ?case 
   unfolding qFreshAll_simps(2) qSwapAll_simps(2) liftAll_lift_comp o_def 
   unfolding liftAll_def by presburger
qed (auto simp add: sw_def)

corollary qSwap_preserves_qFresh:
"(qFresh ys (y @ys[z1  z2]_zs) (X #[[z1  z2]]_zs) = qFresh ys y X)"
by(simp add: qSwapAll_preserves_qFreshAll)

lemma qSwap_preserves_qFresh_distinct:
assumes "ys  zs  y  {z1,z2}"
shows "qFresh ys y (X #[[z1  z2]]_zs) = qFresh ys y X"
proof-
  have "y = (y @ys[z1  z2]_zs)" using assms unfolding sw_def by auto
  thus ?thesis using qSwap_preserves_qFresh[of ys zs z1 z2 y] by auto
qed

lemma qFresh_qSwap_exchange1:
"qFresh zs z2 (X #[[z1  z2]]_zs) = qFresh zs z1 X"
proof-
  have "z2 = (z1 @zs[z1  z2]_zs)" unfolding sw_def by auto
  thus ?thesis using qSwap_preserves_qFresh[of zs zs z1 z2 z1 X] by auto
qed

lemma qFresh_qSwap_exchange2:
"qFresh zs z1 X = qFresh zs z2 (X #[[z2  z1]]_zs)"
by (auto simp add: qFresh_qSwap_exchange1 qSwap_sym)

lemmas qSwap_qAFresh_otherSimps =
qSwap_ident qSwap_involutive qAFresh_qSwap_id qSwap_preserves_qAFresh

end

Theory QuasiTerms_PickFresh_Alpha

section ‹Availability of Fresh Variables and Alpha-Equivalence›

theory QuasiTerms_PickFresh_Alpha
imports QuasiTerms_Swap_Fresh 

begin

text‹Here we define good quasi-terms and alpha-equivalence on quasi-terms,
and prove relevant properties
such as the ability to pick fresh variables for good
quasi-terms and the fact that alpha is indeed an equivalence
and is compatible with all the operators.

We do most of the work on freshness and alpha-equivalence
unsortedly, for raw quasi-terms.  (And we do it in such a way that
it then applies immediately to sorted quasi-terms.)
We do need sortedness of variables (as well as a cardinality
assumption), however, for alpha-equivalence to have the desired properties.
Therefore we work in a locale.›

subsection ‹The FixVars locale›

definition var_infinite where
"var_infinite (_ :: 'var) ==
 infinite (UNIV :: 'var set)"

definition var_regular where
"var_regular (_ :: 'var) ==
 regular |UNIV :: 'var set|"

definition varSort_lt_var where
"varSort_lt_var (_ :: 'varSort) (_ :: 'var) ==
 |UNIV :: 'varSort set| <o |UNIV :: 'var set|"

locale FixVars =
  fixes dummyV :: 'var and dummyVS :: 'varSort
  assumes var_infinite: "var_infinite (undefined :: 'var)"
  and var_regular: "var_regular (undefined :: 'var)"
  and varSort_lt_var: "varSort_lt_var (undefined :: 'varSort) (undefined :: 'var)"

(*********************************************)
context FixVars
begin

lemma varSort_lt_var_INNER:
"|UNIV :: 'varSort set| <o |UNIV :: 'var set|"
using varSort_lt_var
unfolding varSort_lt_var_def by simp

lemma varSort_le_Var:
"|UNIV :: 'varSort set| ≤o |UNIV :: 'var set|"
using varSort_lt_var_INNER ordLess_imp_ordLeq by auto

theorem var_infinite_INNER: "infinite (UNIV :: 'var set)"
using var_infinite unfolding var_infinite_def by simp

theorem var_regular_INNER: "regular |UNIV :: 'var set|"
using var_regular unfolding var_regular_def by simp

theorem infinite_var_regular_INNER:
"infinite (UNIV :: 'var set)  regular |UNIV :: 'var set|"
by (simp add: var_infinite_INNER var_regular_INNER)

(* Below and elsewhere: We want both full generality and usefulness in one single 
theorem, and therefore we include as a disjunction the general condition w.r.t. the variable cardinality
and the stronger (most often needed) one of finiteness.  This way, we need not
invoke variable infiniteness each time we want to use the finiteness. *)

theorem finite_ordLess_var:
"( |S| <o |UNIV :: 'var set|  finite S) = ( |S| <o |UNIV :: 'var set| )"
by (auto simp add: var_infinite_INNER finite_ordLess_infinite2)

subsection ‹Good quasi-terms›

text ‹Essentially, good quasi-term items
   will be those with meaningful binders and
   not too many variables.  Good quasi-terms are a concept intermediate
   between (raw) quasi-terms and sorted quasi-terms.  This concept was chosen to be strong
   enough to facilitate proofs of most of the desired properties of alpha-equivalence, avoiding,
   {\em for most of the hard part of the work},
   the overhead of sortedness.  Since we later prove that quasi-terms
   are good,
   all the results are then immediately transported to a sorted setting.›

function
qGood :: "('index,'bindex,'varSort,'var,'opSym)qTerm  bool"
and
qGoodAbs :: "('index,'bindex,'varSort,'var,'opSym)qAbs  bool"
where
"qGood (qVar xs x) = True"
|
"qGood (qOp delta inp binp) =
 (liftAll qGood inp  liftAll qGoodAbs binp 
  |{i. inp i  None}| <o |UNIV :: 'var set| 
  |{i. binp i  None}| <o |UNIV :: 'var set| )"
|
"qGoodAbs (qAbs xs x X) = qGood X"
by (pat_completeness, auto)
termination
apply(relation qTermLess)
apply(simp_all add: qTermLess_wf)
by(auto simp add: qTermLess_def)

fun qGoodItem :: "('index,'bindex,'varSort,'var,'opSym)qTermItem  bool" where
"qGoodItem (Inl qX) = qGood qX"
|
"qGoodItem (Inr qA) = qGoodAbs qA"

lemma qSwapAll_preserves_qGoodAll1:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs" and zs x y
shows
"(qGood X  qGood (X #[[x  y]]_zs)) 
 (qGoodAbs A  qGoodAbs (A $[[x  y]]_zs))"
apply(rule qTerm_induct[of _ _ X A])
apply(simp_all add: sw_def)
unfolding lift_def liftAll_def apply auto
apply(case_tac "inp i", auto)
apply(case_tac "binp i", auto)
proof-
  fix inp::"('index,('index,'bindex,'varSort,'var,'opSym)qTerm)input" and zs xs x y
  let ?K1 = "{i. X. inp i = Some X}"
  let ?K2 = "{i. X. (case inp i of None  None | Some X  Some (X #[[x  y]]_zs))
                     = Some X}"
  assume "|?K1| <o |UNIV :: 'var set|"
  moreover have "?K1 = ?K2" by(auto, case_tac "inp x", auto)
  ultimately show "|?K2| <o |UNIV :: 'var set|" by simp
next
  fix binp::"('bindex,('index,'bindex,'varSort,'var,'opSym)qAbs)input" and zs xs x y
  let ?K1 = "{i. A. binp i = Some A}"
  let ?K2 = "{i. A. (case binp i of None  None | Some A  Some (A $[[x  y]]_zs))
                     = Some A}"
  assume "|?K1| <o |UNIV :: 'var set|"
  moreover have "?K1 = ?K2" by(auto, case_tac "binp x", auto)
  ultimately show "|?K2| <o |UNIV :: 'var set|" by simp
qed

corollary qSwap_preserves_qGood1:
"qGood X  qGood (X #[[x  y]]_zs)"
by(simp add: qSwapAll_preserves_qGoodAll1)

corollary qSwapAbs_preserves_qGoodAbs1:
"qGoodAbs A  qGoodAbs (A $[[x  y]]_zs)"
by(simp add: qSwapAll_preserves_qGoodAll1)

lemma qSwap_preserves_qGood2:
assumes "qGood(X #[[x  y]]_zs)"
shows "qGood X" 
by (metis assms qSwap_involutive qSwap_preserves_qGood1)

lemma qSwapAbs_preserves_qGoodAbs2:
assumes "qGoodAbs(A $[[x  y]]_zs)"
shows "qGoodAbs A" 
by (metis assms qSwapAbs_preserves_qGoodAbs1 qSwapAll_involutive)
 
lemma qSwap_preserves_qGood: "(qGood (X #[[x  y]]_zs)) = (qGood X)"
using qSwap_preserves_qGood1 qSwap_preserves_qGood2 by blast

lemma qSwapAbs_preserves_qGoodAbs:
"(qGoodAbs (A $[[x  y]]_zs)) = (qGoodAbs A)"
using qSwapAbs_preserves_qGoodAbs1 qSwapAbs_preserves_qGoodAbs2 by blast

lemma qSwap_twice_preserves_qGood:
"(qGood ((X #[[x  y]]_zs) #[[x'  y']]_zs')) = (qGood X)"
by (simp add: qSwap_preserves_qGood)

lemma qSwapped_preserves_qGood:
"(X,Y)  qSwapped  qGood Y = qGood X"
apply (induct rule: qSwapped.induct) 
using qSwap_preserves_qGood by auto

lemma qGood_qTerm_templateInduct[case_names Rel Var Op Abs]:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm"
and A::"('index,'bindex,'varSort,'var,'opSym)qAbs" and phi phiAbs rel
assumes
REL: " X Y. qGood X; (X,Y)  rel  qGood Y  qSkel Y = qSkel X" and
Var: " xs x. phi (qVar xs x)" and
Op: " delta inp binp. |{i. inp i  None}| <o |UNIV :: 'var set|;
                        |{i. binp i  None}| <o |UNIV :: 'var set|;
                        liftAll (λX. qGood X  phi X) inp;
                        liftAll (λA. qGoodAbs A  phiAbs A) binp
                    phi (qOp delta inp binp)" and
Abs: " xs x X. qGood X;  Y. (X,Y)  rel  phi Y
                  phiAbs (qAbs xs x X)"
shows
"(qGood X  phi X)  (qGoodAbs A  phiAbs A)"
apply(induct rule: qTerm_templateInduct[of "{(X,Y). qGood X  (X,Y)  rel}"]) 
using assms by (simp_all add: liftAll_def)

lemma qGood_qTerm_rawInduct[case_names Var Op Abs]:
fixes X :: "('index,'bindex,'varSort,'var,'opSym)qTerm"
and A::"('index,'bindex,'varSort,'var,'opSym)qAbs" and phi phiAbs
assumes
Var: " xs x. phi (qVar xs x)" and
Op: " delta inp binp. |{i. inp i  None}| <o |UNIV :: 'var set|;
                        |{i. binp i  None}| <o |UNIV :: 'var set|;
                        liftAll (λ X. qGood X  phi X) inp;
                        liftAll (λ A. qGoodAbs A  phiAbs A) binp
                        phi (qOp delta inp binp)" and
Abs: " xs x X. qGood X; phi X   phiAbs (qAbs xs x X)"
shows "(qGood X  phi X)  (qGoodAbs A  phiAbs A)"
apply(induct rule: qGood_qTerm_templateInduct [of Id])
by(simp_all add: assms)

lemma qGood_qTerm_induct[case_names Var Op Abs]:
fixes X :: "('index,'bindex,'varSort,'var,'opSym)qTerm"
and A::"('index,'bindex,'varSort,'var,'opSym)qAbs" and phi phiAbs
assumes
Var: " xs x. phi (qVar xs x)" and
Op: " delta inp binp. |{i. inp i  None}| <o |UNIV :: 'var set|;
                        |{i. binp i  None}| <o |UNIV :: 'var set|;
                        liftAll (λ X. qGood X  phi X) inp;
                        liftAll (λ A. qGoodAbs A  phiAbs A) binp
                        phi (qOp delta inp binp)" and
Abs: " xs x X. qGood X;
                  Y. qGood Y  qSkel Y = qSkel X  phi Y;
                  Y. (X,Y)  qSwapped  phi Y
                  phiAbs (qAbs xs x X)"
shows
"(qGood X  phi X)  (qGoodAbs A  phiAbs A)"
apply(induct rule: qGood_qTerm_templateInduct
           [of "qSwapped  {(X,Y). qGood Y  qSkel Y = qSkel X}"])
using qSwapped_qSkel qSwapped_preserves_qGood
by(auto simp add: assms)

text "A form specialized for mutual induction
(this time, without the cardinality hypotheses):"

lemma qGood_qTerm_induct_mutual[case_names Var1 Var2 Op1 Op2 Abs1 Abs2]:
fixes X :: "('index,'bindex,'varSort,'var,'opSym)qTerm"
and A::"('index,'bindex,'varSort,'var,'opSym)qAbs" and phi1 phi2 phiAbs1 phiAbs2
assumes
Var1: " xs x. phi1 (qVar xs x)" and
Var2: " xs x. phi2 (qVar xs x)" and
Op1: " delta inp binp. liftAll (λ X. qGood X  phi1 X) inp;
                         liftAll (λ A. qGoodAbs A  phiAbs1 A) binp
                         phi1 (qOp delta inp binp)" and
Op2: " delta inp binp. liftAll (λ X. qGood X  phi2 X) inp;
                         liftAll (λ A. qGoodAbs A  phiAbs2 A) binp
                         phi2 (qOp delta inp binp)" and
Abs1: " xs x X. qGood X;
                   Y. qGood Y  qSkel Y = qSkel X  phi1 Y;
                   Y. qGood Y  qSkel Y = qSkel X  phi2 Y;
                   Y. (X,Y)  qSwapped  phi1 Y;
                   Y. (X,Y)  qSwapped  phi2 Y
                  phiAbs1 (qAbs xs x X)" and
Abs2: " xs x X. qGood X;
                   Y. qGood Y  qSkel Y = qSkel X  phi1 Y;
                   Y. qGood Y  qSkel Y = qSkel X  phi2 Y;
                   Y. (X,Y)  qSwapped  phi1 Y;
                   Y. (X,Y)  qSwapped  phi2 Y;
                  phiAbs1 (qAbs xs x X)
                  phiAbs2 (qAbs xs x X)"
shows
"(qGood X  (phi1 X  phi2 X)) 
 (qGoodAbs A  (phiAbs1 A  phiAbs2 A))"
apply(induct rule: qGood_qTerm_induct[of _ _ X A])
by(auto simp add: assms liftAll_and)

subsection ‹The ability to pick fresh variables›

lemma single_non_qAFreshAll_ordLess_var:
fixes X :: "('index,'bindex,'varSort,'var,'opSym)qTerm"
and A::"('index,'bindex,'varSort,'var,'opSym)qAbs"
shows
"(qGood X  |{x. ¬ qAFresh xs x X}| <o |UNIV :: 'var set| ) 
 (qGoodAbs A  |{x. ¬ qAFreshAbs xs x A}| <o |UNIV :: 'var set| )"
proof(induct rule: qGood_qTerm_rawInduct)
  case (Var xs x)
  then show ?case using infinite_var_regular_INNER by simp
next
  case (Op delta inp binp) 
  let ?Left = "{x. ¬ qAFresh xs x (qOp delta inp binp)}"
  obtain J where J_def: "J = {i.  X. inp i = Some X}" by blast
  let ?S = " i  J. {x.  X. inp i = Some X  ¬ qAFresh xs x X}"
  {fix i
   obtain K where K_def: "K = {X. inp i = Some X}" by blast
   have "finite K" unfolding K_def by (cases "inp i", auto)
   hence "|K| <o |UNIV :: 'var set|" using var_infinite_INNER finite_ordLess_infinite2 by auto
   moreover have " X  K. |{x. ¬ qAFresh xs x X}| <o |UNIV :: 'var set|"
   unfolding K_def using Op unfolding liftAll_def by simp
   ultimately have "| X  K. {x. ¬ qAFresh xs x X}| <o |UNIV :: 'var set|"
   using var_regular_INNER by (simp add: regular_UNION)
   moreover
   have "{x. X. inp i = Some X  ¬ qAFresh xs x X} =
         ( X  K. {x. ¬ qAFresh xs x X})" unfolding K_def by blast
   ultimately
   have "|{x. X. inp i = Some X  ¬ qAFresh xs x X}| <o |UNIV :: 'var set|"
   by simp
  }
  moreover have "|J| <o |UNIV :: 'var set|" unfolding J_def 
  using Op unfolding liftAll_def by simp
  ultimately
  have 1: "|?S| <o |UNIV :: 'var set|"
  using var_regular_INNER by (simp add: regular_UNION)
  (*  *)
  obtain Ja where Ja_def: "Ja = {i.  A. binp i = Some A}" by blast
  let ?Sa = " i  Ja. {x.  A. binp i = Some A  ¬ qAFreshAbs xs x A}"
  {fix i
   obtain K where K_def: "K = {A. binp i = Some A}" by blast
   have "finite K" unfolding K_def by (cases "binp i", auto)
   hence "|K| <o |UNIV :: 'var set|" using var_infinite_INNER finite_ordLess_infinite2 by auto
   moreover have " A  K. |{x. ¬ qAFreshAbs xs x A}| <o |UNIV :: 'var set|"
   unfolding K_def using Op unfolding liftAll_def by simp
   ultimately have "| A  K. {x. ¬ qAFreshAbs xs x A}| <o |UNIV :: 'var set|"
   using var_regular_INNER by (simp add: regular_UNION)
   moreover
   have "{x. A. binp i = Some A  ¬ qAFreshAbs xs x A} =
         ( A  K. {x. ¬ qAFreshAbs xs x A})" unfolding K_def by blast
   ultimately
   have "|{x. A. binp i = Some A  ¬ qAFreshAbs xs x A}| <o |UNIV :: 'var set|"
   by simp
  }
  moreover have "|Ja| <o |UNIV :: 'var set|" 
  unfolding Ja_def using Op unfolding liftAll_def by simp
  ultimately have "|?Sa| <o |UNIV :: 'var set|" 
  using var_regular_INNER by (simp add: regular_UNION)
  with 1 have "|?S Un ?Sa| <o |UNIV :: 'var set|"
  using var_infinite_INNER card_of_Un_ordLess_infinite by auto
  moreover have "?Left = ?S Un ?Sa"
  by (auto simp: J_def Ja_def liftAll_def ) 
  ultimately show ?case by simp
next
  case (Abs xsa x X) 
  let ?Left = "{xa. xs = xsa  xa = x  ¬ qAFresh xs xa X}"
  have "|{x}| <o |UNIV :: 'var set|" by (auto simp add: var_infinite_INNER)
  hence "|{x}  {x. ¬ qAFresh xs x X}| <o |UNIV :: 'var set|"
  using Abs var_infinite_INNER card_of_Un_ordLess_infinite by blast
  moreover
  {have "?Left  {x}  {x. ¬ qAFresh xs x X}" by blast
   hence "|?Left| ≤o |{x}  {x. ¬ qAFresh xs x X}|" using card_of_mono1 by auto
  }
  ultimately show ?case using ordLeq_ordLess_trans by auto 
qed 

corollary single_non_qAFresh_ordLess_var:
"qGood X  |{x. ¬ qAFresh xs x X}| <o |UNIV :: 'var set|"
by(simp add: single_non_qAFreshAll_ordLess_var)

corollary single_non_qAFreshAbs_ordLess_var:
"qGoodAbs A  |{x. ¬ qAFreshAbs xs x A}| <o |UNIV :: 'var set|"
by(simp add: single_non_qAFreshAll_ordLess_var)

lemma single_non_qFresh_ordLess_var:
assumes "qGood X"
shows "|{x. ¬ qFresh xs x X}| <o |UNIV :: 'var set|"
using qAFresh_imp_qFresh card_of_mono1 single_non_qAFresh_ordLess_var 
ordLeq_ordLess_trans by (metis Collect_mono assms)

lemma single_non_qFreshAbs_ordLess_var:
assumes "qGoodAbs A"
shows "|{x. ¬ qFreshAbs xs x A}| <o |UNIV :: 'var set|"
using qAFreshAll_imp_qFreshAll card_of_mono1 single_non_qAFreshAbs_ordLess_var
ordLeq_ordLess_trans by (metis Collect_mono assms)

lemma non_qAFresh_ordLess_var:
assumes GOOD: " X  XS. qGood X" and Var: "|XS| <o |UNIV :: 'var set|"
shows "|{x| x X. X  XS  ¬ qAFresh xs x X}| <o |UNIV :: 'var set|"
proof-
  define K and F where "K  {x| x X. X  XS  ¬ qAFresh xs x X}"  
  and "F  (λ X. {x. X  XS  ¬ qAFresh xs x X})" 
  have "K = ( X  XS. F X)" unfolding K_def F_def by auto
  moreover have " X  XS. |F X| <o |UNIV :: 'var set|"
  unfolding F_def using GOOD single_non_qAFresh_ordLess_var by auto
  ultimately have "|K| <o |UNIV :: 'var set|" using var_regular_INNER Var 
  by(auto simp add: regular_UNION)
  thus ?thesis unfolding K_def .
qed

lemma non_qAFresh_or_in_ordLess_var:
assumes Var: "|V| <o |UNIV :: 'var set|" and "|XS| <o |UNIV :: 'var set|" and " X  XS. qGood X"
shows "|{x| x X. (x  V  (X  XS  ¬ qAFresh xs x X))}| <o |UNIV :: 'var set|"
proof-
  define J and K where "J  {x| x X. (x  V  (X  XS  ¬ qAFresh xs x X))}"  
  and "K  {x| x X. X  XS  ¬ qAFresh xs x X}"  
  have "J  K  V" unfolding J_def K_def by auto
  hence "|J| ≤o |K  V|" using card_of_mono1 by auto
  moreover
  {have "|K| <o |UNIV :: 'var set|" unfolding K_def using assms non_qAFresh_ordLess_var by auto
   hence "|K  V| <o |UNIV :: 'var set|" using Var var_infinite_INNER card_of_Un_ordLess_infinite by auto
  }
  ultimately have "|J| <o |UNIV :: 'var set|" using ordLeq_ordLess_trans by blast
  thus ?thesis unfolding J_def .
qed

lemma obtain_set_qFresh_card_of:
assumes  "|V| <o |UNIV :: 'var set|" and "|XS| <o |UNIV :: 'var set|" and " X  XS. qGood X"
shows " W. infinite W  W Int V = {} 
             ( x  W.  X  XS. qAFresh xs x X  qFresh xs x X)"
proof-
  define J where "J  {x| x X. (x  V  (X  XS  ¬ qAFresh xs x X))}" 
  let ?W = "UNIV - J"
  have "|J| <o |UNIV :: 'var set|"
  unfolding J_def using assms non_qAFresh_or_in_ordLess_var by auto
  hence  "infinite ?W" using var_infinite_INNER subset_ordLeq_diff_infinite[of _ J] by auto
  moreover
  have "?W  V = {}  ( x  ?W.  X  XS. qAFresh xs x X  qFresh xs x X)"
  unfolding J_def using qAFresh_imp_qFresh by fastforce
  ultimately show ?thesis by blast
qed

lemma obtain_set_qFresh:
assumes "finite V  |V| <o |UNIV :: 'var set|" and "finite XS  |XS| <o |UNIV :: 'var set|" and
        " X  XS. qGood X"
shows " W. infinite W  W Int V = {} 
            ( x  W.  X  XS. qAFresh xs x X  qFresh xs x X)"
using assms
by(fastforce simp add: var_infinite_INNER obtain_set_qFresh_card_of)

lemma obtain_qFresh_card_of:
assumes "|V| <o |UNIV :: 'var set|" and "|XS| <o |UNIV :: 'var set|" and " X  XS. qGood X"
shows " x. x  V  ( X  XS. qAFresh xs x X  qFresh xs x X)"
proof-
  obtain W where "infinite W" and
  *: "W  V = {}  ( x  W.  X  XS. qAFresh xs x X  qFresh xs x X)"
  using assms obtain_set_qFresh_card_of by blast
  then obtain x where "x  W" using infinite_imp_nonempty by fastforce
  thus ?thesis using * by auto
qed

lemma obtain_qFresh:
assumes "finite V  |V| <o |UNIV :: 'var set|" and "finite XS  |XS| <o |UNIV :: 'var set|" and
        " X  XS. qGood X"
shows " x. x  V  ( X  XS. qAFresh xs x X  qFresh xs x X)"
using assms
by(fastforce simp add: var_infinite_INNER obtain_qFresh_card_of)

definition pickQFresh where
"pickQFresh xs V XS ==
 SOME x. x  V  ( X  XS. qAFresh xs x X  qFresh xs x X)"

lemma pickQFresh_card_of:
assumes "|V| <o |UNIV :: 'var set|" and "|XS| <o |UNIV :: 'var set|" and " X  XS. qGood X"
shows "pickQFresh xs V XS  V 
       ( X  XS. qAFresh xs (pickQFresh xs V XS) X  qFresh xs (pickQFresh xs V XS) X)"
unfolding pickQFresh_def apply(rule someI_ex)
using assms obtain_qFresh_card_of by blast

lemma pickQFresh:
assumes "finite V  |V| <o |UNIV :: 'var set|" and "finite XS  |XS| <o |UNIV :: 'var set|" and
        " X  XS. qGood X"
shows "pickQFresh xs V XS  V 
       ( X  XS. qAFresh xs (pickQFresh xs V XS) X  qFresh xs (pickQFresh xs V XS) X)"
unfolding pickQFresh_def apply(rule someI_ex) 
using assms by(auto simp add: obtain_qFresh)

end (* context FixVars *)
(*****************************************)

subsection ‹Alpha-equivalence›

subsubsection ‹Definition›

definition aux_alpha_ignoreSecond ::
"('index,'bindex,'varSort,'var,'opSym)qTerm * ('index,'bindex,'varSort,'var,'opSym)qTerm +
 ('index,'bindex,'varSort,'var,'opSym)qAbs * ('index,'bindex,'varSort,'var,'opSym)qAbs
 
 ('index,'bindex,'varSort,'var,'opSym)qTermItem"
where
"aux_alpha_ignoreSecond K ==
 case K of Inl(X,Y)  termIn X
          |Inr(A,B)  absIn A"

lemma aux_alpha_ignoreSecond_qTermLessQSwapped_wf:
"wf(inv_image qTermQSwappedLess aux_alpha_ignoreSecond)"
using qTermQSwappedLess_wf wf_inv_image by auto

(*  *)
function
alpha and alphaAbs
where
"alpha (qVar xs x) (qVar xs' x')  xs = xs'  x = x'"
|
"alpha (qOp delta inp binp) (qOp delta' inp' binp') 
 delta = delta'  sameDom inp inp'  sameDom binp binp' 
 liftAll2 alpha inp inp' 
 liftAll2 alphaAbs binp binp'"
|
"alpha (qVar xs x) (qOp delta' inp' binp')  False"
|
"alpha (qOp delta inp binp) (qVar xs' x')  False"
|
"alphaAbs (qAbs xs x X) (qAbs xs' x' X') 
 xs = xs' 
 ( y. y  {x,x'}  qAFresh xs y X  qAFresh xs' y X' 
       alpha (X #[[y  x]]_xs) (X' #[[y  x']]_xs'))"
by(pat_completeness, auto)
termination
apply(relation "inv_image qTermQSwappedLess aux_alpha_ignoreSecond")
apply(simp add: aux_alpha_ignoreSecond_qTermLessQSwapped_wf)
by(auto simp add: qTermQSwappedLess_def qTermLess_modulo_def
   aux_alpha_ignoreSecond_def qSwap_qSwapped)

abbreviation alpha_abbrev (infix "#=" 50) where "X #= Y  alpha X Y"
abbreviation alphaAbs_abbrev (infix "$=" 50) where "A $= B  alphaAbs A B"

(*********************************************)
context FixVars
begin

subsubsection ‹Simplification and elimination rules›

lemma alpha_inp_None:
"qOp delta inp binp #= qOp delta' inp' binp' 
 (inp i = None) = (inp' i = None)"
by(auto simp add: sameDom_def)

lemma alpha_binp_None:
"qOp delta inp binp #= qOp delta' inp' binp' 
 (binp i = None) = (binp' i = None)"
by(auto simp add: sameDom_def)

lemma qVar_alpha_iff:
"qVar xs x #= X'  X' = qVar xs x"
by(cases X', auto)

lemma alpha_qVar_iff:
"X #= qVar xs' x'  X = qVar xs' x'"
by(cases X, auto)

lemma qOp_alpha_iff:
"qOp delta inp binp #= X' 
 ( inp' binp'.
    X' = qOp delta inp' binp'  sameDom inp inp'  sameDom binp binp' 
    liftAll2 (λY Y'. Y #= Y') inp inp' 
    liftAll2 (λA A'. A $= A') binp binp')"
by(cases X') auto

lemma alpha_qOp_iff:
"X #= qOp delta' inp' binp' 
 ( inp binp. X = qOp delta' inp binp  sameDom inp inp'  sameDom binp binp' 
    liftAll2 (λY Y'. Y #= Y') inp inp' 
    liftAll2 (λA A'. A $= A') binp binp')"
by(cases X) auto

lemma qAbs_alphaAbs_iff:
"qAbs xs x X $= A' 
 ( x' y X'. A' = qAbs xs x' X' 
             y  {x,x'}  qAFresh xs y X  qAFresh xs y X' 
             (X #[[y  x]]_xs) #= (X' #[[y  x']]_xs))"
by(cases A') auto

lemma alphaAbs_qAbs_iff:
"A $= qAbs xs' x' X' 
 ( x y X. A = qAbs xs' x X 
            y  {x,x'}  qAFresh xs' y X  qAFresh xs' y X' 
            (X #[[y  x]]_xs') #= (X' #[[y  x']]_xs'))"
by(cases A) auto

subsubsection ‹Basic properties›

text‹In a nutshell: ``alpha" is included in the kernel of ``qSkel", is
an equivalence on good quasi-terms, preserves goodness,
and all operators and relations (except ``qAFresh") preserve alpha.›

lemma alphaAll_qSkelAll:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs"
shows
"( X'. X #= X'  qSkel X = qSkel X') 
 ( A'. A $= A'  qSkelAbs A = qSkelAbs A')"
proof(induction rule: qTerm_induct)
  case (Var xs x)
  then show ?case unfolding qVar_alpha_iff by simp
next
  case (Op delta inp binp)
  show ?case proof safe
    fix X'
    assume "qOp delta inp binp #= X'" 
    then obtain inp' binp' where X'eq: "X' = qOp delta inp' binp'" and
       1: "sameDom inp inp'  sameDom binp binp'" and
       2: "liftAll2 (λ Y Y'. Y #= Y') inp inp' 
           liftAll2 (λ A A'. A $= A') binp binp'"
    unfolding qOp_alpha_iff by auto
    from Op.IH 1 2
    show "qSkel (qOp delta inp binp) = qSkel X'"     
    by (simp add: X'eq fun_eq_iff option.case_eq_if
        lift_def liftAll_def sameDom_def liftAll2_def)  
  qed
next
  case (Abs xs x X)
  show ?case
  proof safe
    fix A' assume "qAbs xs x X $= A'" 
    then obtain X' x' y where A'eq: "A' = qAbs xs x' X'" and
    *: "(X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)" unfolding qAbs_alphaAbs_iff by auto
    moreover have "(X, X #[[y  x]]_xs)  qSwapped" using qSwap_qSwapped by fastforce
    ultimately have "qSkel(X #[[y  x]]_xs) = qSkel(X' #[[y  x']]_xs)" 
    using Abs.IH by blast
    hence "qSkel X = qSkel X'" by(auto simp add: qSkel_qSwap)
    thus "qSkelAbs (qAbs xs x X) = qSkelAbs A'" unfolding A'eq by simp
  qed
qed

corollary alpha_qSkel:
fixes X X' :: "('index,'bindex,'varSort,'var,'opSym)qTerm"
shows "X #= X'  qSkel X = qSkel X'"
by(simp add: alphaAll_qSkelAll)

text‹Symmetry of alpha is a property that holds for arbitrary 
(not necessarily good) quasi-terms.›

lemma alphaAll_sym:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs"
shows
"( X'. X #= X'  X' #= X)  ( A'. A $= A'  A' $= A)"
proof(induction rule: qTerm_induct)
  case (Var xs x)
  then show ?case unfolding qVar_alpha_iff by simp
next
  case (Op delta inp binp)
  show ?case proof safe
    fix X' assume "qOp delta inp binp #= X'" 
    then obtain inp' binp' where X': "X' = qOp delta inp' binp'" and
    1: "sameDom inp inp'  sameDom binp binp'"
    and 2: "liftAll2 (λY Y'. Y #= Y') inp inp' 
          liftAll2 (λA A'. A $= A') binp binp'"
    unfolding qOp_alpha_iff by auto
    thus "X' #= qOp delta inp binp"
    unfolding X' using Op.IH 1 2
    by (auto simp add: fun_eq_iff option.case_eq_if
        lift_def liftAll_def sameDom_def liftAll2_def)
  qed
next
  case (Abs xs x X)
  show ?case proof safe 
    fix A' assume "qAbs xs x X $= A'"
    then obtain x' y X' where
    1: "A' = qAbs xs x' X'  y  {x, x'}  qAFresh xs y X  qAFresh xs y X'" and
    "(X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)"
    unfolding qAbs_alphaAbs_iff by auto
    moreover have "(X, X #[[y  x]]_xs)  qSwapped" by (simp add: qSwap_qSwapped)
    ultimately have "(X' #[[y  x']]_xs) #= (X #[[y  x]]_xs)" using Abs.IH by simp
    thus "A' $= qAbs xs x X" using 1 by auto
  qed
qed 

corollary alpha_sym:
fixes X X' :: "('index,'bindex,'varSort,'var,'opSym)qTerm"
shows "X #= X'  X' #= X"
by(simp add: alphaAll_sym)

corollary alphaAbs_sym:
fixes A A' ::"('index,'bindex,'varSort,'var,'opSym)qAbs"
shows "A $= A'  A' $= A"
by(simp add: alphaAll_sym)

text‹Reflexivity does not hold for arbitrary quasi-terms, but onl;y for good 
ones. Indeed, the proof requires picking a fresh variable,
   guaranteed to be possible only if the quasi-term is good.›

lemma alphaAll_refl:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs"
shows
"(qGood X  X #= X)  (qGoodAbs A  A $= A)"
apply(rule qGood_qTerm_induct, simp_all)
unfolding liftAll_def sameDom_def liftAll2_def apply auto
proof-
  fix xs x X
  assume "qGood X" and
        IH: "Y. (X,Y)  qSwapped  Y #= Y"
  then obtain y where 1: "y  x  qAFresh xs y X"
  using obtain_qFresh[of "{x}" "{X}"] by auto
  hence "(X, X #[[y  x]]_xs)  qSwapped" using qSwap_qSwapped by auto
  hence "(X #[[y  x]]_xs) #= (X #[[y  x]]_xs)" using IH by simp
  thus "y. y  x  qAFresh xs y X  (X #[[y  x]]_xs) #= (X #[[y  x]]_xs)"
  using 1 by blast
qed

corollary alpha_refl:
fixes X :: "('index,'bindex,'varSort,'var,'opSym)qTerm"
shows "qGood X  X #= X"
by(simp add: alphaAll_refl)

corollary alphaAbs_refl:
fixes A ::"('index,'bindex,'varSort,'var,'opSym)qAbs"
shows "qGoodAbs A  A $= A"
by(simp add: alphaAll_refl)

lemma alphaAll_preserves_qGoodAll1:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs"
shows
"(qGood X  ( X'. X #= X'  qGood X')) 
 (qGoodAbs A  ( A'. A $= A'  qGoodAbs A'))"
apply(rule qTerm_induct, auto)
unfolding qVar_alpha_iff apply(auto)
proof-
  fix delta inp binp X'
  assume
  IH1: "liftAll (λY. qGood Y  (Y'. Y #= Y'  qGood Y')) inp"
  and IH2: "liftAll (λA. qGoodAbs A  (A'. A $= A'  qGoodAbs A')) binp"
  and *: "liftAll qGood inp"  "liftAll qGoodAbs binp"
  and **: "|{i. Y. inp i = Some Y}| <o |UNIV :: 'var set|"
          "|{i. A. binp i = Some A}| <o |UNIV :: 'var set|"
  and "qOp delta inp binp #= X'"
  then obtain inp' binp' where
  X'eq: "X' = qOp delta inp' binp'" and
  2: "sameDom inp inp'  sameDom binp binp'" and
  3: "liftAll2 (λY Y'. Y #= Y') inp inp' 
      liftAll2 (λA A'. A $= A') binp binp'"
  unfolding qOp_alpha_iff by auto
  show "qGood X'"
  unfolding X'eq apply simp unfolding liftAll_def apply auto
  proof-
    fix i Y' assume inp': "inp' i = Some Y'"
    then obtain Y where inp: "inp i = Some Y"
    using 2 unfolding sameDom_def by fastforce
    hence "Y #= Y'" using inp' 3 unfolding liftAll2_def by blast
    moreover have "qGood Y" using * inp unfolding liftAll_def by simp
    ultimately show "qGood Y'" using IH1 inp unfolding liftAll_def by blast
  next
    fix i A' assume binp': "binp' i = Some A'"
    then obtain A where binp: "binp i = Some A"
    using 2 unfolding sameDom_def by fastforce
    hence "A $= A'" using binp' 3 unfolding liftAll2_def by blast
    moreover have "qGoodAbs A" using * binp unfolding liftAll_def by simp
    ultimately show "qGoodAbs A'" using IH2 binp unfolding liftAll_def by blast
  next
    have "{i. Y'. inp' i = Some Y'} = {i. Y. inp i = Some Y}"
    using 2 unfolding sameDom_def by force
    thus "|{i. Y'. inp' i = Some Y'}| <o |UNIV :: 'var set|" using ** by simp
  next
    have "{i. A'. binp' i = Some A'} = {i. A. binp i = Some A}"
    using 2 unfolding sameDom_def by force
    thus "|{i. A'. binp' i = Some A'}| <o |UNIV :: 'var set|" using ** by simp
  qed
next
  fix xs x X A'
  assume IH: "Y. (X,Y)  qSwapped  qGood Y  (X'. Y #= X'  qGood X')"
         and *: "qGood X" and "qAbs xs x X $= A'"
  then obtain x' y X' where "A' = qAbs xs x' X'" and
       1: "(X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)"
  unfolding qAbs_alphaAbs_iff by auto
  thus "qGoodAbs A'"
  proof(auto)
    have "(X, X #[[y  x]]_xs)  qSwapped" by(auto simp add: qSwap_qSwapped)
    moreover have "qGood(X #[[y  x]]_xs)" using * qSwap_preserves_qGood by auto
    ultimately have "qGood(X' #[[y  x']]_xs)" using 1 IH by auto
    thus "qGood X'" using * qSwap_preserves_qGood by auto
  qed
qed

corollary alpha_preserves_qGood1:
"X #= X'; qGood X  qGood X'"
using alphaAll_preserves_qGoodAll1 by blast

corollary alphaAbs_preserves_qGoodAbs1:
"A $= A'; qGoodAbs A  qGoodAbs A'"
using alphaAll_preserves_qGoodAll1 by blast

lemma alpha_preserves_qGood2:
"X #= X'; qGood X'  qGood X"
using alpha_sym alpha_preserves_qGood1 by blast

lemma alphaAbs_preserves_qGoodAbs2:
"A $= A'; qGoodAbs A'  qGoodAbs A"
using alphaAbs_sym alphaAbs_preserves_qGoodAbs1 by blast

lemma alpha_preserves_qGood:
"X #= X'  qGood X = qGood X'"
using alpha_preserves_qGood1 alpha_preserves_qGood2 by blast

lemma alphaAbs_preserves_qGoodAbs:
"A $= A'  qGoodAbs A = qGoodAbs A'"
using alphaAbs_preserves_qGoodAbs1 alphaAbs_preserves_qGoodAbs2 by blast

lemma alpha_qSwap_preserves_qGood1:
assumes ALPHA: "(X #[[y  x]]_zs) #= (X' #[[y'  x']]_zs')" and
        GOOD: "qGood X"
shows "qGood X'"
proof-
  have "qGood(X #[[y  x]]_zs)" using GOOD qSwap_preserves_qGood by auto
  hence "qGood (X' #[[y'  x']]_zs')" using ALPHA alpha_preserves_qGood by auto
  thus "qGood X'" using qSwap_preserves_qGood by auto
qed

lemma alpha_qSwap_preserves_qGood2:
assumes ALPHA: "(X #[[y  x]]_zs) #= (X' #[[y'  x']]_zs')" and
        GOOD': "qGood X'"
shows "qGood X"
proof-
  have "qGood(X' #[[y'  x']]_zs')" using GOOD' qSwap_preserves_qGood by auto
  hence "qGood (X #[[y  x]]_zs)" using ALPHA alpha_preserves_qGood by auto
  thus "qGood X" using qSwap_preserves_qGood by auto
qed

lemma alphaAbs_qSwapAbs_preserves_qGoodAbs2:
assumes ALPHA: "(A $[[y  x]]_zs) $= (A' $[[y'  x']]_zs')" and
        GOOD': "qGoodAbs A'"
shows "qGoodAbs A"
proof-
  have "qGoodAbs(A' $[[y'  x']]_zs')" using GOOD' qSwapAbs_preserves_qGoodAbs by auto
  hence "qGoodAbs (A $[[y  x]]_zs)" using ALPHA alphaAbs_preserves_qGoodAbs by auto
  thus "qGoodAbs A" using qSwapAbs_preserves_qGoodAbs by auto
qed

lemma alpha_qSwap_preserves_qGood:
assumes ALPHA: "(X #[[y  x]]_zs) #= (X' #[[y'  x']]_zs')"
shows "qGood X = qGood X'"
using assms alpha_qSwap_preserves_qGood1
      alpha_qSwap_preserves_qGood2 by auto

lemma qSwapAll_preserves_alphaAll:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs" and z1 z2 zs
shows
"(qGood X  ( X' zs z1 z2. X #= X' 
                             (X #[[z1  z2]]_zs) #= (X' #[[z1  z2]]_zs))) 
 (qGoodAbs A  ( A' zs z1 z2. A $= A' 
                                (A $[[z1  z2]]_zs) $= (A' $[[z1  z2]]_zs)))"
proof(induction rule: qGood_qTerm_induct)
  case (Var xs x)
  then show ?case unfolding qVar_alpha_iff by simp
next
  case (Op delta inp binp) 
  show ?case proof safe
    fix X' zs z1 z2
    assume "qOp delta inp binp #= X'" term X' term binp
    then obtain inp' binp' where X'eq: "X' = qOp delta inp' binp'" and
    1: "sameDom inp inp'  sameDom binp binp'"
    and 2: "liftAll2 (λ Y Y'. Y #= Y') inp inp' 
          liftAll2 (λ A A'. A $= A') binp binp'"
    unfolding qOp_alpha_iff by auto
    thus "((qOp delta inp binp) #[[z1  z2]]_zs) #= (X' #[[z1  z2]]_zs)"
    unfolding X'eq using Op.IH
    by (auto simp add: fun_eq_iff option.case_eq_if
       lift_def liftAll_def sameDom_def liftAll2_def)
  qed
next 
  case (Abs xs x X) 
  show ?case proof safe
    fix A' zs z1 z2 assume "qAbs xs x X $= A'"
    then obtain x' y X' where A': "A' = qAbs xs x' X'" and
    y_not: "y  {x, x'}" and y_fresh: "qAFresh xs y X  qAFresh xs y X'" and
    alpha: "(X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)"
    unfolding qAbs_alphaAbs_iff by auto
    hence goodX': "qGood X'" using ‹qGood X alpha_qSwap_preserves_qGood by fastforce
    (* *)
    obtain u where u_notin: "u  {x,x',z1,z2,y}" and
                   u_freshXX': "qAFresh xs u X  qAFresh xs u X'"
    using  ‹qGood X goodX' obtain_qFresh[of "{x,x',z1,z2,y}" "{X,X'}"] by auto
    hence u_not: "u  (x @xs[z1  z2]_zs)  u  (x' @xs[z1  z2]_zs)"
    unfolding sw_def using u_notin by auto
    have u_fresh: "qAFresh xs u (X #[[z1  z2]]_zs)  qAFresh xs u (X' #[[z1  z2]]_zs)"
    using u_freshXX' u_notin by(auto simp add: qSwap_preserves_qAFresh_distinct)
    (*  *)
    have "((X #[[z1  z2]]_zs) #[[u  (x @xs[z1  z2]_zs)]]_xs) =
          (((X #[[y  x]]_xs) #[[u  y]]_xs) #[[z1  z2]]_zs)"
    using y_fresh u_freshXX' u_notin by (simp add: qSwap_3commute)
    moreover
    {have 1: "(X, X #[[y  x]]_xs)  qSwapped" by(simp add: qSwap_qSwapped)
     hence "((X #[[y  x]]_xs) #[[u  y]]_xs) #= ((X' #[[y  x']]_xs) #[[u  y]]_xs)"
     using alpha Abs.IH by auto
     moreover have "(X, (X #[[y  x]]_xs) #[[u  y]]_xs)  qSwapped"
     using 1 by(auto simp add: qSwapped.Swap)
     ultimately have "(((X #[[y  x]]_xs) #[[u  y]]_xs) #[[z1  z2]]_zs) #=
                      (((X' #[[y  x']]_xs) #[[u  y]]_xs) #[[z1  z2]]_zs)"
     using Abs.IH by auto
    }
    moreover
    have "(((X' #[[y  x']]_xs) #[[u  y]]_xs) #[[z1  z2]]_zs) =
          ((X' #[[z1  z2]]_zs) #[[u  (x' @xs[z1  z2]_zs)]]_xs)"
    using y_fresh u_freshXX' u_notin by (auto simp add: qSwap_3commute)
    ultimately have "((X #[[z1  z2]]_zs) #[[u  (x @xs[z1  z2]_zs)]]_xs) #=
                     ((X' #[[z1  z2]]_zs) #[[u  (x' @xs[z1  z2]_zs)]]_xs)" by simp
    thus "((qAbs xs x X) $[[z1  z2]]_zs) $= (A' $[[z1  z2]]_zs)"
    unfolding A' using u_not u_fresh by auto
  qed
qed 

corollary qSwap_preserves_alpha:
assumes "qGood X  qGood X'" and "X #= X'"
shows "(X #[[z1  z2]]_zs) #= (X' #[[z1  z2]]_zs)"
using assms alpha_preserves_qGood qSwapAll_preserves_alphaAll by blast

corollary qSwapAbs_preserves_alphaAbs:
assumes "qGoodAbs A  qGoodAbs A'" and "A $= A'"
shows "(A $[[z1  z2]]_zs) $= (A' $[[z1  z2]]_zs)"
using assms alphaAbs_preserves_qGoodAbs qSwapAll_preserves_alphaAll by blast

lemma qSwap_twice_preserves_alpha:
assumes "qGood X  qGood X'" and "X #= X'"
shows "((X #[[z1  z2]]_zs) #[[u1  u2]]_us) #= ((X' #[[z1  z2]]_zs) #[[u1  u2]]_us)"
  by (simp add: assms qSwap_preserves_alpha qSwap_preserves_qGood)

lemma alphaAll_trans:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs"
shows
"(qGood X  ( X' X''. X #= X'  X' #= X''  X #= X'')) 
 (qGoodAbs A  ( A' A''. A $= A'  A' $= A''  A $= A''))"
proof(induction rule: qGood_qTerm_induct)
  case (Var xs x)
  then show ?case by (simp add: qVar_alpha_iff)
next
  case (Op delta inp binp) 
  show ?case proof safe
    fix X' X'' assume "qOp delta inp binp #= X'" and *: "X' #= X''"
    then obtain inp' binp' where
    1: "X' = qOp delta inp' binp'" and
    2: "sameDom inp inp'  sameDom binp binp'" and
    3: "liftAll2 (λY Y'. Y #= Y') inp inp' 
      liftAll2 (λA A'. A $= A') binp binp'"
    unfolding qOp_alpha_iff by auto
    obtain inp'' binp'' where
    11: "X'' = qOp delta inp'' binp''" and
    22: "sameDom inp' inp''  sameDom binp' binp''" and
    33: "liftAll2 (λY' Y''. Y' #= Y'') inp' inp'' 
         liftAll2 (λA' A''. A' $= A'') binp' binp''"
    using * unfolding 1 unfolding qOp_alpha_iff by auto
    have "liftAll2 (#=) inp inp''" unfolding liftAll2_def proof safe
      fix i Y Y''
      assume inp: "inp i = Some Y" and inp'': "inp'' i = Some Y''"
      then obtain Y' where inp': "inp' i = Some Y'"
      using 2 unfolding sameDom_def by force
      hence "Y #= Y'" using inp 3 unfolding liftAll2_def by blast
      moreover have "Y' #= Y''" using inp' inp'' 33 unfolding liftAll2_def by blast
      ultimately show "Y #= Y''" using inp Op.IH unfolding liftAll_def by blast
    qed
    moreover have "liftAll2 ($=) binp binp''" unfolding liftAll2_def proof safe
      fix i A A''
      assume binp: "binp i = Some A" and binp'': "binp'' i = Some A''"
      then obtain A' where binp': "binp' i = Some A'"
      using 2 unfolding sameDom_def by force
      hence "A $= A'" using binp 3 unfolding liftAll2_def by blast
      moreover have "A' $= A''" using binp' binp'' 33 unfolding liftAll2_def by blast
      ultimately show "A $= A''" using binp Op.IH unfolding liftAll_def by blast
    qed
    ultimately show "qOp delta inp binp #= X''"
    by (simp add: 11 2 22 sameDom_trans[of inp inp'] sameDom_trans[of binp binp'])
  qed
next 
  case (Abs xs x X)
  show ?case proof safe  
    fix A' A''
    assume "qAbs xs x X $= A'" and *: "A' $= A''"
    then obtain x' y X' where A': "A' = qAbs xs x' X'" and y_not: "y  {x, x'}" and
    y_fresh: "qAFresh xs y X  qAFresh xs y X'" and
    alpha: "(X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)"
    unfolding qAbs_alphaAbs_iff by auto
    obtain x'' z X'' where A'': "A'' = qAbs xs x'' X''" and z_not: "z  {x', x''}" and
    z_fresh: "qAFresh xs z X'  qAFresh xs z X''" and
    alpha': "(X' #[[z  x']]_xs) #= (X'' #[[z  x'']]_xs)"
    using * unfolding A' qAbs_alphaAbs_iff by auto
    have goodX': "qGood X'"
    using alpha ‹qGood X alpha_qSwap_preserves_qGood by fastforce
    hence goodX'': "qGood X''"
    using alpha' alpha_qSwap_preserves_qGood by fastforce
    have good: "qGood((X #[[y  x]]_xs))  qGood((X' #[[z  x']]_xs))"
    using ‹qGood X goodX' qSwap_preserves_qGood by auto
    (* *)   
    obtain u where u_not: "u  {x,x',x'',y,z}" and
             u_fresh: "qAFresh xs u X  qAFresh xs u X'  qAFresh xs u X''"
    using ‹qGood X goodX' goodX''  
    using obtain_qFresh[of "{x,x',x'',y,z}" "{X, X', X''}"] by auto
    (*  *)
    {have "(X #[[u  x]]_xs) = ((X #[[y  x]]_xs) #[[u  y]]_xs)"
     using u_fresh y_fresh by (auto simp add: qAFresh_qSwap_compose)
     moreover
     have "((X #[[y  x]]_xs) #[[u  y]]_xs) #= ((X' #[[y  x']]_xs) #[[u  y]]_xs)"
     using good alpha qSwap_preserves_alpha by fastforce
     moreover have "((X' #[[y  x']]_xs) #[[u  y]]_xs) = (X' #[[u  x']]_xs)"
     using u_fresh y_fresh by (auto simp add: qAFresh_qSwap_compose)
     ultimately have "(X #[[u  x]]_xs) #= (X' #[[u  x']]_xs)" by simp
    }
    moreover
    {have "(X' #[[u  x']]_xs) = ((X' #[[z  x']]_xs) #[[u  z]]_xs)"
     using u_fresh z_fresh by (auto simp add: qAFresh_qSwap_compose)
     moreover
     have "((X' #[[z  x']]_xs) #[[u  z]]_xs) #= ((X'' #[[z  x'']]_xs) #[[u  z]]_xs)"
     using good alpha' qSwap_preserves_alpha by fastforce
     moreover have "((X'' #[[z  x'']]_xs) #[[u  z]]_xs) = (X'' #[[u  x'']]_xs)"
     using u_fresh z_fresh by (auto simp add: qAFresh_qSwap_compose)
     ultimately have "(X' #[[u  x']]_xs) #= (X'' #[[u  x'']]_xs)" by simp
    }
    moreover have "(X, X #[[u  x]]_xs)  qSwapped" by (simp add: qSwap_qSwapped)
    ultimately have "(X #[[u  x]]_xs) #= (X'' #[[u  x'']]_xs)"
    using Abs.IH by blast
    thus "qAbs xs x X $= A''"
    unfolding A'' using u_not u_fresh by auto
  qed
qed

corollary alpha_trans:
assumes "qGood X  qGood X'  qGood X''" "X #= X'"  "X' #= X''"
shows "X #= X''" 
by (meson alphaAll_trans alpha_preserves_qGood assms)

corollary alphaAbs_trans:
assumes "qGoodAbs A  qGoodAbs A'  qGoodAbs A''"
and "A $= A'"  "A' $= A''"
shows "A $= A''"
using assms alphaAbs_preserves_qGoodAbs alphaAll_trans by blast 

lemma alpha_trans_twice:
"qGood X  qGood X'  qGood X''  qGood X''';
  X #= X'; X' #= X''; X'' #= X'''  X #= X'''"
using alpha_trans by blast

lemma alphaAbs_trans_twice:
"qGoodAbs A  qGoodAbs A'  qGoodAbs A''  qGoodAbs A''';
  A $= A'; A' $= A''; A'' $= A'''  A $= A'''"
using alphaAbs_trans by blast

lemma qAbs_preserves_alpha:
assumes ALPHA: "X #= X'" and GOOD: "qGood X  qGood X'"
shows "qAbs xs x X $= qAbs xs x X'"
proof-
  have "qGood X  qGood X'" using GOOD ALPHA by(auto simp add: alpha_preserves_qGood)
  then obtain y where y_not: "y  x" and
                      y_fresh: "qAFresh xs y X  qAFresh xs y X'"
  using GOOD obtain_qFresh[of "{x}" "{X,X'}"] by auto
  hence "(X #[[y  x]]_xs) #= (X' #[[y  x]]_xs)"
  using ALPHA GOOD by(simp add: qSwap_preserves_alpha)
  thus ?thesis using y_not y_fresh by auto
qed

corollary qAbs_preserves_alpha2:
assumes ALPHA: "X #= X'" and GOOD: "qGoodAbs(qAbs xs x X)  qGoodAbs (qAbs xs x X')"
shows "qAbs xs x X $= qAbs xs x X'"
using assms by (intro qAbs_preserves_alpha) auto

subsubsection ‹Picking fresh representatives›

lemma qAbs_alphaAbs_qSwap_qAFresh:
assumes GOOD: "qGood X" and FRESH: "qAFresh ys x' X"
shows "qAbs ys x X $= qAbs ys x' (X #[[x'  x]]_ys)"
proof-
  obtain y where 1: "y  {x,x'}" and 2: "qAFresh ys y X"
  using GOOD obtain_qFresh[of "{x,x'}" "{X}"] by auto
  hence 3: "qAFresh ys y (X #[[x'  x]]_ys)"
  by (auto simp add: qSwap_preserves_qAFresh_distinct)
  (*  *)
  have "(X #[[y  x]]_ys) = ((X #[[x'  x]]_ys) #[[y  x']]_ys)"
  using FRESH 2 by (auto simp add: qAFresh_qSwap_compose)
  moreover have "qGood (X #[[y  x]]_ys)"
  using 1 GOOD qSwap_preserves_qGood by auto
  ultimately have "(X #[[y  x]]_ys) #= ((X #[[x'  x]]_ys) #[[y  x']]_ys)"
  using alpha_refl by simp
  (*  *)
  thus ?thesis using 1 2 3 assms by auto
qed

lemma qAbs_ex_qAFresh_rep:
assumes GOOD: "qGood X" and FRESH: "qAFresh xs x' X"
shows " X'. qGood X'  qAbs xs x X $= qAbs xs x' X'"
proof-
  have 1: "qGood (X #[[x'  x]]_xs)" using assms qSwap_preserves_qGood by auto
  show ?thesis
  apply(rule exI[of _ "X #[[x'  x]]_xs"])
  using assms 1 qAbs_alphaAbs_qSwap_qAFresh by fastforce
qed

subsection ‹Properties of swapping and freshness modulo alpha›

lemma qFreshAll_imp_ex_qAFreshAll:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs" and zs fZs
assumes FIN: "finite V"
shows
"(qGood X 
  (( z  V.  zs  fZs z. qFresh zs z X) 
   ( X'. X #= X'  ( z  V.  zs  fZs z. qAFresh zs z X')))) 
 (qGoodAbs A 
  (( z  V.  zs  fZs z. qFreshAbs zs z A) 
   ( A'. A $= A'  ( z  V.  zs  fZs z. qAFreshAbs zs z A'))))"
proof(induction rule: qGood_qTerm_induct)
  case (Var xs x)
  show ?case  
  by (metis alpha_qVar_iff qAFreshAll_simps(1) qFreshAll_simps(1))  
next
  case (Op delta inp binp)
  show ?case proof safe 
    assume *: "zV. zsfZs z. qFresh zs z (qOp delta inp binp)"
    define phi and phiAbs where  
    "phi  (λ(Y::('index,'bindex,'varSort,'var,'opSym)qTerm) Y'.
            Y #= Y'  (zV. zsfZs z. qAFresh zs z Y'))" and 
    "phiAbs  (λ(A::('index,'bindex,'varSort,'var,'opSym)qAbs) A'.
               A $= A'  (zV. zsfZs z. qAFreshAbs zs z A'))" 
    have ex_phi: " i Y. inp i = Some Y  Y'. phi Y Y'"
    unfolding phi_def using Op.IH * by (auto simp add: liftAll_def)
    have ex_phiAbs: " i A. binp i = Some A  A'. phiAbs A A'"
    unfolding phiAbs_def using Op.IH * by (auto simp add: liftAll_def)
    define inp' and binp' where  
    "inp'  λ i. case inp i of Some Y  Some (SOME Y'. phi Y Y') |None  None" and  
    "binp'  λ i. case binp i of Some A  Some (SOME A'. phiAbs A A') |None  None"
    show "X'. qOp delta inp binp #= X'  (zV. zsfZs z. qAFresh zs z X')"
    by (intro exI[of _ "qOp delta inp' binp'"])  
    (auto simp add: inp'_def binp'_def option.case_eq_if sameDom_def liftAll_def liftAll2_def,
    (meson ex_phi phi_def ex_phiAbs phiAbs_def some_eq_ex)+)
  qed
next 
  case (Abs xs x X)
  show ?case proof safe   
    assume *: "zV. zsfZs z. qFreshAbs zs z (qAbs xs x X)"
    obtain y where y_not_x: "y  x" and y_not_V: "y  V"
    and y_afresh: "qAFresh xs y X"
    using FIN ‹qGood X obtain_qFresh[of "V  {x}" "{X}"] by auto
    hence y_fresh: "qFresh xs y X" using qAFresh_imp_qFresh by fastforce
    obtain Y where Y_def: "Y = (X #[[y  x ]]_xs)" by blast
    have alphaXY: "qAbs xs x X $= qAbs xs y Y"
    using ‹qGood X y_afresh qAbs_alphaAbs_qSwap_qAFresh unfolding Y_def by fastforce
    have "zV. zs  fZs z. qFresh zs z Y"
    unfolding Y_def 
    by (metis * not_equals_and_not_equals_not_in qAFresh_imp_qFresh qAFresh_qSwap_exchange1 
        qFreshAbs.simps qSwap_preserves_qFresh_distinct y_afresh y_not_V)
    moreover have "(X,Y)  qSwapped" unfolding Y_def by(simp add: qSwap_qSwapped)
    ultimately obtain Y' where "Y #= Y'" and **: "zV. zs  fZs z. qAFresh zs z Y'"
    using Abs.IH by blast
    moreover have "qGood Y" unfolding Y_def using  ‹qGood X qSwap_preserves_qGood by auto
    ultimately have "qAbs xs y Y $= qAbs xs y Y'" using qAbs_preserves_alpha by blast
    moreover have "qGoodAbs(qAbs xs x X)" using  ‹qGood X by simp
    ultimately have "qAbs xs x X $= qAbs xs y Y'" using alphaXY alphaAbs_trans by blast
    moreover have "zV. zs  fZs z. qAFreshAbs zs z (qAbs xs y Y')" using ** y_not_V by auto
    ultimately show "A'. qAbs xs x X $= A'  (zV. zs  fZs z. qAFreshAbs zs z A')"
    by blast  
  qed
qed

corollary qFresh_imp_ex_qAFresh:
assumes "finite V" and "qGood X" and " z  V. zs  fZs z. qFresh zs z X"
shows " X'. qGood X'  X #= X'  ( z  V. zs  fZs z. qAFresh zs z X')"
by (metis alphaAll_preserves_qGoodAll1 assms qFreshAll_imp_ex_qAFreshAll)

corollary qFreshAbs_imp_ex_qAFreshAbs:
assumes "finite V" and "qGoodAbs A" and " z  V. zs  fZs z. qFreshAbs zs z A"
shows " A'. qGoodAbs A'  A $= A'  ( z  V. zs  fZs z. qAFreshAbs zs z A')"
by (metis alphaAll_preserves_qGoodAll1 assms qFreshAll_imp_ex_qAFreshAll)

lemma qFresh_imp_ex_qAFresh1:
assumes "qGood X" and "qFresh zs z X"
shows " X'. qGood X'  X #= X'  qAFresh zs z X'"
using assms qFresh_imp_ex_qAFresh[of "{z}" _ "undefined(z := {zs})"] by fastforce

lemma qFreshAbs_imp_ex_qAFreshAbs1:
assumes "finite V" and "qGoodAbs A" and "qFreshAbs zs z A"
shows " A'. qGoodAbs A'  A $= A'  qAFreshAbs zs z A'"
using assms qFreshAbs_imp_ex_qAFreshAbs[of "{z}" _ "undefined(z := {zs})"] by fastforce

lemma qFresh_imp_ex_qAFresh2:
assumes "qGood X" and "qFresh xs x X" and "qFresh ys y X"
shows " X'. qGood X'  X #= X'  qAFresh xs x X'  qAFresh ys y X'"
using assms
qFresh_imp_ex_qAFresh[of "{x}" _ "undefined(x := {xs,ys})"] 
qFresh_imp_ex_qAFresh[of "{x,y}" _ "(undefined(x := {xs}))(y := {ys})"] 
by (cases "x = y") auto

lemma qFreshAbs_imp_ex_qAFreshAbs2:
assumes "finite V" and "qGoodAbs A" and "qFreshAbs xs x A" and "qFreshAbs ys y A"
shows " A'. qGoodAbs A'  A $= A'  qAFreshAbs xs x A'  qAFreshAbs ys y A'"
using assms
qFreshAbs_imp_ex_qAFreshAbs[of "{x}" _ "undefined(x := {xs,ys})"] 
qFreshAbs_imp_ex_qAFreshAbs[of "{x,y}" _ "(undefined(x := {xs}))(y := {ys})"] 
by (cases "x = y") auto

lemma qAFreshAll_qFreshAll_preserves_alphaAll:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs" and zs z
shows
"(qGood X 
  (qAFresh zs z X  ( X'. X #= X'  qFresh zs z X'))) 
 (qGoodAbs A 
  (qAFreshAbs zs z A  ( A'. A $= A'  qFreshAbs zs z A')))"
proof(induction rule: qGood_qTerm_induct)
  case (Var xs x)
  thus ?case unfolding qVar_alpha_iff by simp 
next
  case (Op delta inp binp) 
  show ?case proof safe
    fix X'  
    assume afresh: "qAFresh zs z (qOp delta inp binp)" 
    and "qOp delta inp binp #= X'" 
    then obtain inp' and binp' where X'eq: "X' = qOp delta inp' binp'" and
    *: "(i. (inp i = None) = (inp' i = None)) 
      (i. (binp i = None) = (binp' i = None))" and
    **: "(i Y Y'. inp i = Some Y  inp' i = Some Y'  Y #= Y') 
       (i A A'. binp i = Some A  binp' i = Some A'  A $= A')"
    unfolding qOp_alpha_iff sameDom_def liftAll2_def by auto
    {fix i Y' assume inp': "inp' i = Some Y'"
     then obtain Y where inp: "inp i = Some Y" using * by fastforce
     hence "Y #= Y'" using inp' ** by blast
     hence "qFresh zs z Y'" using inp Op.IH afresh by (auto simp: liftAll_def)  
    }
    moreover
    {fix i A' assume binp': "binp' i = Some A'"
     then obtain A where binp: "binp i = Some A" using * by fastforce
     hence "A $= A'" using binp' ** by blast
     hence "qFreshAbs zs z A'" using binp Op.IH afresh by (auto simp: liftAll_def) 
    }
    ultimately show "qFresh zs z X'"
    unfolding X'eq apply simp unfolding liftAll_def by simp
  qed
next
  case (Abs xs x X)
  show ?case proof safe 
    fix A'
    assume "qAbs xs x X $= A'" and afresh: "qAFreshAbs zs z (qAbs xs x X)"
    then obtain x' y X' where A'eq: "A' = qAbs xs x' X'" and
    ynot: "y  {x, x'}" and y_afresh: "qAFresh xs y X  qAFresh xs y X'" and
    alpha: "(X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)"
    unfolding qAbs_alphaAbs_iff by auto
    (*  *)
    have goodXxy: "qGood(X #[[y  x]]_xs)" using ‹qGood X qSwap_preserves_qGood by auto
    hence goodX'yx': "qGood(X' #[[y  x']]_xs)" using alpha alpha_preserves_qGood by auto
    hence "qGood X'" using qSwap_preserves_qGood by auto
    then obtain u where u_afresh: "qAFresh xs u X  qAFresh xs u X'"
    and unot: "u  {x,x',z}" using ‹qGood X obtain_qFresh[of "{x,x',z}" "{X,X'}"] by auto
    (* *)
    have "(X #[[u  x]]_xs) = ((X #[[y  x]]_xs) #[[u  y]]_xs) 
          (X' #[[u  x']]_xs) = ((X' #[[y  x']]_xs) #[[u  y]]_xs)"
    using u_afresh y_afresh qAFresh_qSwap_compose by fastforce
    moreover have "((X #[[y  x]]_xs) #[[u  y]]_xs) #= ((X' #[[y  x']]_xs) #[[u  y]]_xs)"
    using goodXxy goodX'yx' alpha qSwap_preserves_alpha by fastforce
    ultimately have alpha: "(X #[[u  x]]_xs) #= (X' #[[u  x']]_xs)" by simp
    (*  *)
    moreover have "(X, X #[[u  x]]_xs)  qSwapped" by (simp add: qSwap_qSwapped)
    moreover have "qAFresh zs z (X #[[u  x]]_xs)"
    using unot afresh by(auto simp add: qSwap_preserves_qAFresh_distinct)
    ultimately have "qFresh zs z (X' #[[u  x']]_xs)" using afresh Abs.IH by simp
    hence "zs = xs  z = x'  qFresh zs z X'"
    using unot afresh qSwap_preserves_qFresh_distinct[of zs xs z] by fastforce
    thus "qFreshAbs zs z A'" unfolding A'eq by simp
  qed
qed

corollary qAFresh_qFresh_preserves_alpha:
"qGood X; qAFresh zs z X; X #= X'  qFresh zs z X'"
by(simp add: qAFreshAll_qFreshAll_preserves_alphaAll)

corollary qAFreshAbs_imp_qFreshAbs_preserves_alphaAbs:
"qGoodAbs A; qAFreshAbs zs z A; A $= A'  qFreshAbs zs z A'"
by(simp add: qAFreshAll_qFreshAll_preserves_alphaAll)

lemma qFresh_preserves_alpha1:
assumes "qGood X" and "qFresh zs z X" and "X #= X'"
shows "qFresh zs z X'" 
by (meson alpha_sym alpha_trans assms qAFresh_qFresh_preserves_alpha qFresh_imp_ex_qAFresh1)

lemma qFreshAbs_preserves_alphaAbs1:
assumes "qGoodAbs A" and "qFreshAbs zs z A" and "A $= A'"
shows "qFreshAbs zs z A'" 
by (meson alphaAbs_sym alphaAbs_trans assms finite.emptyI 
  qAFreshAbs_imp_qFreshAbs_preserves_alphaAbs qFreshAbs_imp_ex_qAFreshAbs1)
 
lemma qFresh_preserves_alpha:
assumes "qGood X  qGood X'" and "X #= X'"
shows "qFresh zs z X  qFresh zs z X'"
using alpha_preserves_qGood alpha_sym assms qFresh_preserves_alpha1 by blast
 
lemma qFreshAbs_preserves_alphaAbs:
assumes "qGoodAbs A  qGoodAbs A'" and "A $= A'"
shows "qFreshAbs zs z A = qFreshAbs zs z A'"
using assms alphaAbs_preserves_qGoodAbs alphaAbs_sym qFreshAbs_preserves_alphaAbs1 by blast

lemma alpha_qFresh_qSwap_id:
assumes "qGood X" and "qFresh zs z1 X" and "qFresh zs z2 X"
shows "(X #[[z1  z2]]_zs) #= X"
proof-
  obtain X' where 1: "X #= X'" and "qAFresh zs z1 X'  qAFresh zs z2 X'"
  using assms qFresh_imp_ex_qAFresh2 by force
  hence "(X' #[[z1  z2]]_zs) = X'" using qAFresh_qSwap_id by auto
  moreover have "(X #[[z1  z2]]_zs) #= (X' #[[z1  z2]]_zs)"
  using assms 1 by (auto simp add: qSwap_preserves_alpha)
  moreover have "X' #= X" using 1 alpha_sym by auto
  moreover have "qGood(X #[[z1  z2]]_zs)" using assms qSwap_preserves_qGood by auto
  ultimately show ?thesis using alpha_trans by auto
qed

lemma alphaAbs_qFreshAbs_qSwapAbs_id:
assumes "qGoodAbs A" and "qFreshAbs zs z1 A" and "qFreshAbs zs z2 A"
shows "(A $[[z1  z2]]_zs) $= A"
proof-
  obtain A' where 1: "A $= A'" and "qAFreshAbs zs z1 A'  qAFreshAbs zs z2 A'"
  using assms qFreshAbs_imp_ex_qAFreshAbs2 by force
  hence "(A' $[[z1  z2]]_zs) = A'" using qAFreshAll_qSwapAll_id by fastforce
  moreover have "(A $[[z1  z2]]_zs) $= (A' $[[z1  z2]]_zs)"
  using assms 1 by (auto simp add: qSwapAbs_preserves_alphaAbs)
  moreover have "A' $= A" using 1 alphaAbs_sym by auto
  moreover have "qGoodAbs (A $[[z1  z2]]_zs)" using assms qSwapAbs_preserves_qGoodAbs by auto
  ultimately show ?thesis using alphaAbs_trans by auto
qed

lemma alpha_qFresh_qSwap_compose:
assumes GOOD: "qGood X" and "qFresh zs y X" and "qFresh zs z X"
shows "((X #[[y  x]]_zs) #[[z  y]]_zs) #= (X #[[z  x]]_zs)"
proof-
  obtain X' where 1: "X #= X'" and "qAFresh zs y X'  qAFresh zs z X'"
  using assms qFresh_imp_ex_qAFresh2 by force
  hence "((X' #[[y  x]]_zs) #[[z  y]]_zs) = (X' #[[z  x]]_zs)"
  using qAFresh_qSwap_compose by auto
  moreover have "((X #[[y  x]]_zs) #[[z  y]]_zs) #= ((X' #[[y  x]]_zs) #[[z  y]]_zs)"
  using GOOD 1 by (auto simp add: qSwap_twice_preserves_alpha)
  moreover have "(X' #[[z  x]]_zs) #= (X #[[z  x]]_zs)"
  using GOOD 1 by (auto simp add: qSwap_preserves_alpha alpha_sym)
  moreover have "qGood ((X #[[y  x]]_zs) #[[z  y]]_zs)"
  using GOOD by (auto simp add: qSwap_twice_preserves_qGood)
  ultimately show ?thesis using alpha_trans by auto
qed

lemma qAbs_alphaAbs_qSwap_qFresh:
assumes GOOD: "qGood X" and FRESH: "qFresh xs x' X"
shows "qAbs xs x X $= qAbs xs x' (X #[[x'  x]]_xs)"
proof-
  obtain Y where good_Y: "qGood Y" and alpha: "X #= Y" and fresh_Y: "qAFresh xs x' Y"
  using assms qFresh_imp_ex_qAFresh1 by fastforce
  hence "qAbs xs x Y $= qAbs xs x' (Y #[[x'  x]]_xs)"
  using qAbs_alphaAbs_qSwap_qAFresh by blast
  moreover have "qAbs xs x X $= qAbs xs x Y"
  using GOOD alpha qAbs_preserves_alpha by fastforce
  moreover
  {have "Y #[[x'  x]]_xs #= X #[[x'  x]]_xs"
   using GOOD alpha by (auto simp add: qSwap_preserves_alpha alpha_sym)
   moreover have "qGood (Y #[[x'  x]]_xs)" using good_Y qSwap_preserves_qGood by auto
   ultimately have "qAbs xs x' (Y #[[x'  x]]_xs) $= qAbs xs x' (X #[[x'  x]]_xs)"
   using qAbs_preserves_alpha by blast
  }
  moreover have "qGoodAbs (qAbs xs x X)" using GOOD by simp
  ultimately show ?thesis using alphaAbs_trans by blast
qed

lemma alphaAbs_qAbs_ex_qFresh_rep:
assumes GOOD: "qGood X" and FRESH: "qFresh xs x' X"
shows " X'. (X,X')  qSwapped  qGood X'  qAbs xs x X $= qAbs xs x' X'"
proof-
  have 1: "qGood (X #[[x'  x]]_xs)" using assms qSwap_preserves_qGood by auto
  have 2: "(X,X #[[x'  x]]_xs)  qSwapped" by(simp add: qSwap_qSwapped)
  show ?thesis
  apply(rule exI[of _ "X #[[x'  x]]_xs"])
  using assms 1 2 qAbs_alphaAbs_qSwap_qFresh by fastforce
qed
   
subsection ‹Alternative statements of the alpha-clause for bound arguments›

text‹These alternatives are essentially variations with forall/exists and and qFresh/qAFresh.›

(* FIXME: In this subsection I may have proved quite a few useless things. *)

subsubsection ‹First for ``qAFresh"›

definition alphaAbs_ex_equal_or_qAFresh
where
"alphaAbs_ex_equal_or_qAFresh xs x X xs' x' X' ==
 (xs = xs' 
 ( y. (y = x  qAFresh xs y X)  (y = x'  qAFresh xs y X') 
       (X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)))"

definition alphaAbs_ex_qAFresh
where
"alphaAbs_ex_qAFresh xs x X xs' x' X' ==
 (xs = xs' 
 ( y. qAFresh xs y X  qAFresh xs y X' 
       (X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)))"

definition alphaAbs_ex_distinct_qAFresh
where
"alphaAbs_ex_distinct_qAFresh xs x X xs' x' X' ==
 (xs = xs' 
 ( y. y  {x,x'}  qAFresh xs y X  qAFresh xs y X' 
       (X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)))"

definition alphaAbs_all_equal_or_qAFresh
where
"alphaAbs_all_equal_or_qAFresh xs x X xs' x' X' ==
 (xs = xs' 
 ( y. (y = x  qAFresh xs y X)  (y = x'  qAFresh xs y X') 
       (X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)))"

definition alphaAbs_all_qAFresh
where
"alphaAbs_all_qAFresh xs x X xs' x' X' ==
 (xs = xs' 
 ( y. qAFresh xs y X  qAFresh xs y X' 
       (X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)))"

definition alphaAbs_all_distinct_qAFresh
where
"alphaAbs_all_distinct_qAFresh xs x X xs' x' X' ==
 (xs = xs' 
 ( y. y  {x,x'}  qAFresh xs y X  qAFresh xs y X' 
       (X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)))"

lemma alphaAbs_weakestEx_imp_strongestAll:
assumes GOOD_X: "qGood X" and "alphaAbs_ex_equal_or_qAFresh xs x X xs' x' X'"
shows "alphaAbs_all_equal_or_qAFresh xs x X xs' x' X'"
proof-
  obtain y where xs: "xs = xs'" and
  yEqFresh: "(y = x  qAFresh xs y X)  (y = x'  qAFresh xs y X')" and
  alpha: "(X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)"
  using assms by (auto simp add: alphaAbs_ex_equal_or_qAFresh_def)
  show ?thesis
  using xs unfolding alphaAbs_all_equal_or_qAFresh_def
  proof(intro conjI allI impI, simp)
    fix z assume zFresh: "(z = x  qAFresh xs z X)  (z = x'  qAFresh xs z X')"
    have "(X #[[z  x]]_xs) = ((X #[[y  x]]_xs) #[[z  y]]_xs)"
    proof(cases "z = x")
      assume Case1: "z = x"
      thus ?thesis by(auto simp add: qSwap_sym)
    next
      assume Case2: "z  x"
      hence z_fresh: "qAFresh xs z X" using zFresh by auto
      show ?thesis
      proof(cases "y = x")
        assume Case21: "y = x"
        show ?thesis unfolding Case21 by simp
      next
        assume Case22: "y  x"
        hence "qAFresh xs y X" using yEqFresh by auto
        thus ?thesis using z_fresh qAFresh_qSwap_compose by fastforce
      qed
    qed
    moreover
    have "(X' #[[z  x']]_xs) = ((X' #[[y  x']]_xs) #[[z  y]]_xs)"
    proof(cases "z = x'")
      assume Case1: "z = x'"
      thus ?thesis by(auto simp add: qSwap_sym)
    next
      assume Case2: "z  x'"
      hence z_fresh: "qAFresh xs z X'" using zFresh by auto
      show ?thesis
      proof(cases "y = x'")
        assume Case21: "y = x'"
        show ?thesis unfolding Case21 by simp
      next
        assume Case22: "y  x'"
        hence "qAFresh xs y X'" using yEqFresh by auto
        thus ?thesis using z_fresh qAFresh_qSwap_compose by fastforce
      qed
    qed
    moreover
    {have "qGood (X #[[y  x]]_xs)" using GOOD_X qSwap_preserves_qGood by auto
     hence "((X #[[y  x]]_xs) #[[z  y]]_xs) #= ((X' #[[y  x']]_xs) #[[z  y]]_xs)"
     using alpha qSwap_preserves_alpha by fastforce
    }
    ultimately show "(X #[[z  x]]_xs) #= (X' #[[z  x']]_xs)" by simp
  qed
qed

lemma alphaAbs_weakestAll_imp_strongestEx:
assumes GOOD: "qGood X"  "qGood X'"
and "alphaAbs_all_distinct_qAFresh xs x X xs' x' X'"
shows "alphaAbs_ex_distinct_qAFresh xs x X xs' x' X'"
proof-
  have xs: "xs = xs'"
  using assms unfolding alphaAbs_all_distinct_qAFresh_def by auto
  obtain y where y_not:  "y  {x,x'}" and
                 yFresh: "qAFresh xs y X  qAFresh xs y X'"
  using GOOD obtain_qFresh[of  "{x,x'}" "{X,X'}"] by auto
  hence "(X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)"
  using assms unfolding alphaAbs_all_distinct_qAFresh_def by auto
  thus ?thesis unfolding alphaAbs_ex_distinct_qAFresh_def using xs y_not yFresh by auto
qed

(* Note: I do not infer the following from the previous two because
   I do not want to use "qGood X'": *)

lemma alphaAbs_weakestEx_imp_strongestEx:
assumes GOOD: "qGood X"
and "alphaAbs_ex_equal_or_qAFresh xs x X xs' x' X'"
shows "alphaAbs_ex_distinct_qAFresh xs x X xs' x' X'"
proof-
  obtain y where xs: "xs = xs'" and
  yEqFresh: "(y = x  qAFresh xs y X)  (y = x'  qAFresh xs y X')" and
  alpha: "(X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)"
  using assms unfolding alphaAbs_ex_equal_or_qAFresh_def by blast
  hence goodX': "qGood X'"
  using GOOD alpha_qSwap_preserves_qGood by fastforce
  then obtain z where zNot: "z  {x,x',y}" and
                      zFresh: "qAFresh xs z X  qAFresh xs z X'"
  using GOOD obtain_qFresh[of "{x,x',y}" "{X,X'}"] by auto
  have "(X #[[z  x]]_xs) = ((X #[[y  x]]_xs) #[[z  y]]_xs)"
  proof(cases "y = x", simp)
    assume "y  x"  hence "qAFresh xs y X" using yEqFresh by auto
    thus ?thesis using zFresh qAFresh_qSwap_compose by fastforce
  qed
  moreover have "(X' #[[z  x']]_xs) = ((X' #[[y  x']]_xs) #[[z  y]]_xs)"
  proof(cases "y = x'", simp add: qSwap_ident)
    assume "y  x'"  hence "qAFresh xs y X'" using yEqFresh by auto
    thus ?thesis using zFresh qAFresh_qSwap_compose by fastforce
  qed
  moreover
  {have "qGood (X #[[y  x]]_xs)" using GOOD qSwap_preserves_qGood by auto
   hence "((X #[[y  x]]_xs) #[[z  y]]_xs) #= ((X' #[[y  x']]_xs) #[[z  y]]_xs)"
   using alpha by (auto simp add: qSwap_preserves_alpha)
  }
  ultimately have "(X #[[z  x]]_xs) #= (X' #[[z  x']]_xs)" by simp
  thus ?thesis unfolding alphaAbs_ex_distinct_qAFresh_def using xs zNot zFresh by auto
qed

lemma alphaAbs_qAbs_iff_alphaAbs_ex_distinct_qAFresh:
"(qAbs xs x X $= qAbs xs' x' X') = alphaAbs_ex_distinct_qAFresh xs x X xs' x' X'"
unfolding alphaAbs_ex_distinct_qAFresh_def by auto

corollary alphaAbs_qAbs_iff_ex_distinct_qAFresh:
"(qAbs xs x X $= qAbs xs' x' X') =
 (xs = xs' 
  ( y. y  {x,x'}  qAFresh xs y X  qAFresh xs y X' 
         (X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)))"
unfolding alphaAbs_qAbs_iff_alphaAbs_ex_distinct_qAFresh
          alphaAbs_ex_distinct_qAFresh_def by fastforce

lemma alphaAbs_qAbs_iff_alphaAbs_ex_equal_or_qAFresh:
assumes "qGood X"
shows "(qAbs xs x X $= qAbs xs' x' X') =
       alphaAbs_ex_equal_or_qAFresh xs x X xs' x' X'"
proof-
  let ?Left = "qAbs xs x X $= qAbs xs' x' X'"
  let ?Right = "alphaAbs_ex_equal_or_qAFresh xs x X xs' x' X'"
  have "?Left  ?Right" unfolding alphaAbs_ex_equal_or_qAFresh_def by auto
  moreover have "?Right  ?Left"
  using assms alphaAbs_qAbs_iff_alphaAbs_ex_distinct_qAFresh[of _ _ X]
        alphaAbs_weakestEx_imp_strongestEx by auto
  ultimately show ?thesis by auto
qed

corollary alphaAbs_qAbs_iff_ex_equal_or_qAFresh:
assumes "qGood X"
shows
"(qAbs xs x X $= qAbs xs' x' X') =
 (xs = xs' 
  ( y. (y = x  qAFresh xs y X)  (y = x'  qAFresh xs y X') 
         (X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)))"
proof-
  have "(qAbs xs x X $= qAbs xs' x' X') =
        alphaAbs_ex_equal_or_qAFresh xs x X xs' x' X'"
  using assms alphaAbs_qAbs_iff_alphaAbs_ex_equal_or_qAFresh by fastforce
  thus ?thesis unfolding alphaAbs_ex_equal_or_qAFresh_def .
qed

lemma alphaAbs_qAbs_iff_alphaAbs_ex_qAFresh:
assumes "qGood X"
shows "(qAbs xs x X $= qAbs xs' x' X') = alphaAbs_ex_qAFresh xs x X xs' x' X'"
proof-
  let ?Left = "qAbs xs x X $= qAbs xs' x' X'"
  let ?Middle = "alphaAbs_ex_equal_or_qAFresh xs x X xs' x' X'"
  let ?Right = "alphaAbs_ex_qAFresh xs x X xs' x' X'"
  have "?Left  ?Right" unfolding alphaAbs_ex_qAFresh_def by auto
  moreover have "?Right  ?Middle"
  unfolding alphaAbs_ex_qAFresh_def alphaAbs_ex_equal_or_qAFresh_def by auto
  moreover have "?Middle = ?Left"
  using assms alphaAbs_qAbs_iff_alphaAbs_ex_equal_or_qAFresh[of X] by fastforce
  ultimately show ?thesis by blast
qed

corollary alphaAbs_qAbs_iff_ex_qAFresh:
assumes "qGood X"
shows
"(qAbs xs x X $= qAbs xs' x' X') =
 (xs = xs' 
  ( y. qAFresh xs y X  qAFresh xs y X' 
         (X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)))"
proof-
  have "(qAbs xs x X $= qAbs xs' x' X') = alphaAbs_ex_qAFresh xs x X xs' x' X'"
  using assms alphaAbs_qAbs_iff_alphaAbs_ex_qAFresh by fastforce
  thus ?thesis unfolding alphaAbs_ex_qAFresh_def .
qed

lemma alphaAbs_qAbs_imp_alphaAbs_all_equal_or_qAFresh:
assumes "qGood X" and "qAbs xs x X $= qAbs xs' x' X'"
shows "alphaAbs_all_equal_or_qAFresh xs x X xs' x' X'"
using assms alphaAbs_qAbs_iff_alphaAbs_ex_equal_or_qAFresh
      alphaAbs_weakestEx_imp_strongestAll by fastforce

corollary alphaAbs_qAbs_imp_all_equal_or_qAFresh:
assumes "qGood X" and "(qAbs xs x X $= qAbs xs' x' X')"
shows
"(xs = xs' 
  ( y. (y = x  qAFresh xs y X)  (y = x'  qAFresh xs y X') 
        (X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)))"
proof-
  have "alphaAbs_all_equal_or_qAFresh xs x X xs' x' X'"
  using assms alphaAbs_qAbs_imp_alphaAbs_all_equal_or_qAFresh by blast
  thus ?thesis unfolding alphaAbs_all_equal_or_qAFresh_def .
qed

lemma alphaAbs_qAbs_iff_alphaAbs_all_equal_or_qAFresh:
assumes "qGood X" and "qGood X'"
shows "(qAbs xs x X $= qAbs xs' x' X') =
       alphaAbs_all_equal_or_qAFresh xs x X xs' x' X'"
proof-
  let ?Left = "qAbs xs x X $= qAbs xs' x' X'"
  let ?MiddleEx = "alphaAbs_ex_distinct_qAFresh xs x X xs' x' X'"
  let ?MiddleAll = "alphaAbs_all_distinct_qAFresh xs x X xs' x' X'"
  let ?Right = "alphaAbs_all_equal_or_qAFresh xs x X xs' x' X'"
  have "?Left  ?Right"
  using assms alphaAbs_qAbs_imp_alphaAbs_all_equal_or_qAFresh by blast
  moreover have "?Right  ?MiddleAll"
  unfolding alphaAbs_all_equal_or_qAFresh_def alphaAbs_all_distinct_qAFresh_def by auto
  moreover have "?MiddleAll  ?MiddleEx"
  using assms alphaAbs_weakestAll_imp_strongestEx by fastforce
  moreover have "?MiddleEx  ?Left"
  using alphaAbs_qAbs_iff_alphaAbs_ex_distinct_qAFresh[of _ _ X] by fastforce
  ultimately show ?thesis by blast
qed

corollary alphaAbs_qAbs_iff_all_equal_or_qAFresh:
assumes "qGood X" and "qGood X'"
shows "(qAbs xs x X $= qAbs xs' x' X') =
       (xs = xs' 
        ( y. (y = x  qAFresh xs y X)  (y = x'  qAFresh xs y X') 
              (X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)))"
proof-
  have "(qAbs xs x X $= qAbs xs' x' X') =
        alphaAbs_all_equal_or_qAFresh xs x X xs' x' X'"
  using assms alphaAbs_qAbs_iff_alphaAbs_all_equal_or_qAFresh by blast
  thus ?thesis unfolding alphaAbs_all_equal_or_qAFresh_def .
qed

lemma alphaAbs_qAbs_imp_alphaAbs_all_qAFresh:
assumes "qGood X" and "qAbs xs x X $= qAbs xs' x' X'"
shows "alphaAbs_all_qAFresh xs x X xs' x' X'"
proof-
  have "alphaAbs_all_equal_or_qAFresh xs x X xs' x' X'"
  using assms alphaAbs_qAbs_imp_alphaAbs_all_equal_or_qAFresh by blast
  thus ?thesis unfolding alphaAbs_all_qAFresh_def alphaAbs_all_equal_or_qAFresh_def by auto
qed

corollary alphaAbs_qAbs_imp_all_qAFresh:
assumes "qGood X" and "(qAbs xs x X $= qAbs xs' x' X')"
shows
"(xs = xs' 
  ( y. qAFresh xs y X  qAFresh xs y X' 
        (X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)))"
proof-
  have "alphaAbs_all_qAFresh xs x X xs' x' X'"
  using assms alphaAbs_qAbs_imp_alphaAbs_all_qAFresh by blast
  thus ?thesis unfolding alphaAbs_all_qAFresh_def .
qed

lemma alphaAbs_qAbs_iff_alphaAbs_all_qAFresh:
assumes "qGood X" and "qGood X'"
shows "(qAbs xs x X $= qAbs xs' x' X') = alphaAbs_all_qAFresh xs x X xs' x' X'"
proof-
  let ?Left = "qAbs xs x X $= qAbs xs' x' X'"
  let ?MiddleEx = "alphaAbs_ex_distinct_qAFresh xs x X xs' x' X'"
  let ?MiddleAll = "alphaAbs_all_distinct_qAFresh xs x X xs' x' X'"
  let ?Right = "alphaAbs_all_qAFresh xs x X xs' x' X'"
  have "?Left  ?Right" using assms alphaAbs_qAbs_imp_alphaAbs_all_qAFresh by blast
  moreover have "?Right  ?MiddleAll"
  unfolding alphaAbs_all_qAFresh_def alphaAbs_all_distinct_qAFresh_def by auto
  moreover have "?MiddleAll  ?MiddleEx"
  using assms alphaAbs_weakestAll_imp_strongestEx by fastforce
  moreover have "?MiddleEx  ?Left"
  using assms alphaAbs_qAbs_iff_alphaAbs_ex_distinct_qAFresh[of _ _ X] by fastforce
  ultimately show ?thesis by blast
qed

corollary alphaAbs_qAbs_iff_all_qAFresh:
assumes "qGood X" and "qGood X'"
shows "(qAbs xs x X $= qAbs xs' x' X') =
       (xs = xs' 
        ( y. qAFresh xs y X  qAFresh xs y X' 
              (X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)))"
proof-
  have "(qAbs xs x X $= qAbs xs' x' X') =
        alphaAbs_all_qAFresh xs x X xs' x' X'"
  using assms alphaAbs_qAbs_iff_alphaAbs_all_qAFresh by blast
  thus ?thesis unfolding alphaAbs_all_qAFresh_def .
qed

lemma alphaAbs_qAbs_imp_alphaAbs_all_distinct_qAFresh:
assumes "qGood X" and "qAbs xs x X $= qAbs xs' x' X'"
shows "alphaAbs_all_distinct_qAFresh xs x X xs' x' X'"
proof-
  have "alphaAbs_all_equal_or_qAFresh xs x X xs' x' X'"
  using assms alphaAbs_qAbs_imp_alphaAbs_all_equal_or_qAFresh by blast
  thus ?thesis
  unfolding alphaAbs_all_distinct_qAFresh_def alphaAbs_all_equal_or_qAFresh_def by auto
qed

corollary alphaAbs_qAbs_imp_all_distinct_qAFresh:
assumes "qGood X" and "(qAbs xs x X $= qAbs xs' x' X')"
shows
"(xs = xs' 
  ( y. y  {x,x'}  qAFresh xs y X  qAFresh xs y X' 
        (X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)))"
proof-
  have "alphaAbs_all_distinct_qAFresh xs x X xs' x' X'"
  using assms alphaAbs_qAbs_imp_alphaAbs_all_distinct_qAFresh by blast
  thus ?thesis unfolding alphaAbs_all_distinct_qAFresh_def .
qed

lemma alphaAbs_qAbs_iff_alphaAbs_all_distinct_qAFresh:
assumes "qGood X" and "qGood X'"
shows "(qAbs xs x X $= qAbs xs' x' X') =
       alphaAbs_all_distinct_qAFresh xs x X xs' x' X'"
proof-
  let ?Left = "qAbs xs x X $= qAbs xs' x' X'"
  let ?MiddleEx = "alphaAbs_ex_distinct_qAFresh xs x X xs' x' X'"
  let ?MiddleAll = "alphaAbs_all_distinct_qAFresh xs x X xs' x' X'"
  let ?Right = "alphaAbs_all_distinct_qAFresh xs x X xs' x' X'"
  have "?Left  ?Right"
  using assms alphaAbs_qAbs_imp_alphaAbs_all_distinct_qAFresh by blast
  moreover have "?Right  ?MiddleAll"
  unfolding alphaAbs_all_distinct_qAFresh_def alphaAbs_all_distinct_qAFresh_def by auto
  moreover have "?MiddleAll  ?MiddleEx"
  using assms alphaAbs_weakestAll_imp_strongestEx by fastforce
  moreover have "?MiddleEx  ?Left"
  using assms alphaAbs_qAbs_iff_alphaAbs_ex_distinct_qAFresh[of _ _ X] by fastforce
  ultimately show ?thesis by blast
qed

corollary alphaAbs_qAbs_iff_all_distinct_qAFresh:
assumes "qGood X" and "qGood X'"
shows "(qAbs xs x X $= qAbs xs' x' X') =
       (xs = xs' 
        ( y. y  {x,x'}  qAFresh xs y X  qAFresh xs y X' 
              (X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)))"
proof-
  have "(qAbs xs x X $= qAbs xs' x' X') =
        alphaAbs_all_distinct_qAFresh xs x X xs' x' X'"
  using assms alphaAbs_qAbs_iff_alphaAbs_all_distinct_qAFresh by blast
  thus ?thesis unfolding alphaAbs_all_distinct_qAFresh_def .
qed

subsubsection‹Then for ``qFresh"›

definition alphaAbs_ex_equal_or_qFresh
where
"alphaAbs_ex_equal_or_qFresh xs x X xs' x' X' ==
 (xs = xs' 
 ( y. (y = x  qFresh xs y X)  (y = x'  qFresh xs y X') 
       (X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)))"

definition alphaAbs_ex_qFresh
where
"alphaAbs_ex_qFresh xs x X xs' x' X' ==
 (xs = xs' 
 ( y. qFresh xs y X  qFresh xs y X' 
       (X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)))"

definition alphaAbs_ex_distinct_qFresh
where
"alphaAbs_ex_distinct_qFresh xs x X xs' x' X' ==
 (xs = xs' 
 ( y. y  {x,x'}  qFresh xs y X  qFresh xs y X' 
       (X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)))"

definition alphaAbs_all_equal_or_qFresh
where
"alphaAbs_all_equal_or_qFresh xs x X xs' x' X' ==
 (xs = xs' 
 ( y. (y = x  qFresh xs y X)  (y = x'  qFresh xs y X') 
       (X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)))"

definition alphaAbs_all_qFresh
where
"alphaAbs_all_qFresh xs x X xs' x' X' ==
 (xs = xs' 
 ( y. qFresh xs y X  qFresh xs y X' 
       (X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)))"

definition alphaAbs_all_distinct_qFresh
where
"alphaAbs_all_distinct_qFresh xs x X xs' x' X' ==
 (xs = xs' 
 ( y. y  {x,x'}  qFresh xs y X  qFresh xs y X' 
       (X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)))"

lemma alphaAbs_ex_equal_or_qAFresh_imp_qFresh:
"alphaAbs_ex_equal_or_qAFresh xs x X xs' x' X' 
 alphaAbs_ex_equal_or_qFresh xs x X xs' x' X'"
unfolding alphaAbs_ex_equal_or_qAFresh_def alphaAbs_ex_equal_or_qFresh_def
using qAFresh_imp_qFresh[of _ _ X] qAFresh_imp_qFresh[of _ _ X'] by blast

lemma alphaAbs_ex_distinct_qAFresh_imp_qFresh:
"alphaAbs_ex_distinct_qAFresh xs x X xs' x' X' 
 alphaAbs_ex_distinct_qFresh xs x X xs' x' X'"
unfolding alphaAbs_ex_distinct_qAFresh_def alphaAbs_ex_distinct_qFresh_def
using qAFresh_imp_qFresh[of _ _ X] qAFresh_imp_qFresh[of _ _ X'] by blast

lemma alphaAbs_ex_qAFresh_imp_qFresh:
"alphaAbs_ex_qAFresh xs x X xs' x' X' 
 alphaAbs_ex_qFresh xs x X xs' x' X'"
unfolding alphaAbs_ex_qAFresh_def alphaAbs_ex_qFresh_def
using qAFresh_imp_qFresh[of _ _ X] qAFresh_imp_qFresh[of _ _ X'] by blast

lemma alphaAbs_all_equal_or_qFresh_imp_qAFresh:
"alphaAbs_all_equal_or_qFresh xs x X xs' x' X' 
 alphaAbs_all_equal_or_qAFresh xs x X xs' x' X'"
unfolding alphaAbs_all_equal_or_qAFresh_def alphaAbs_all_equal_or_qFresh_def
using qAFresh_imp_qFresh[of _ _ X] qAFresh_imp_qFresh[of _ _ X'] by blast

lemma alphaAbs_all_distinct_qFresh_imp_qAFresh:
"alphaAbs_all_distinct_qFresh xs x X xs' x' X' 
 alphaAbs_all_distinct_qAFresh xs x X xs' x' X'"
using qAFresh_imp_qFresh
unfolding alphaAbs_all_distinct_qAFresh_def alphaAbs_all_distinct_qFresh_def by fastforce

lemma alphaAbs_all_qFresh_imp_qAFresh:
"alphaAbs_all_qFresh xs x X xs' x' X' 
 alphaAbs_all_qAFresh xs x X xs' x' X'"
using qAFresh_imp_qFresh
unfolding alphaAbs_all_qAFresh_def alphaAbs_all_qFresh_def by fastforce

lemma alphaAbs_ex_equal_or_qFresh_imp_alphaAbs_qAbs:
assumes GOOD: "qGood X" and "alphaAbs_ex_equal_or_qFresh xs x X xs' x' X'"
shows "qAbs xs x X $= qAbs xs' x' X'"
proof-
  obtain y where xs: "xs = xs'" and
  yEqFresh: "(y = x  qFresh xs y X)  (y = x'  qFresh xs y X')" and
  alphaXX'yx: "(X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)"
  using assms unfolding alphaAbs_ex_equal_or_qFresh_def by blast
  have " Y. X #= Y  (y = x  qAFresh xs y Y)"
  proof(cases "y = x")
    assume Case1: "y = x" hence "X #= X" using GOOD alpha_refl by auto
    thus ?thesis using Case1 by fastforce
  next
    assume Case2: "y  x" hence "qFresh xs y X" using yEqFresh by blast
    then obtain Y where "X #= Y" and "qAFresh xs y Y"
    using GOOD qFresh_imp_ex_qAFresh1 by fastforce
    thus ?thesis by auto
  qed
  then obtain Y where alphaXY: "X #= Y" and yEqAFresh: "y = x  qAFresh xs y Y" by blast
  hence "(X #[[y  x]]_xs) #= (Y #[[y  x]]_xs)"
  using GOOD qSwap_preserves_alpha by fastforce
  hence alphaYXyx: "(Y #[[y  x]]_xs) #= (X #[[y  x]]_xs)" using alpha_sym by auto
  have goodY: "qGood Y" using alphaXY GOOD alpha_preserves_qGood by auto
  hence goodYyx: "qGood(Y #[[y  x]]_xs)" using qSwap_preserves_qGood by auto
  (*  *)
  have good': "qGood X'"
  using GOOD alphaXX'yx alpha_qSwap_preserves_qGood by fastforce
  have " Y'. X' #= Y'  (y = x'  qAFresh xs y Y')"
  proof(cases "y = x'")
    assume Case1: "y = x'" hence "X' #= X'" using good' alpha_refl by auto
    thus ?thesis using Case1 by fastforce
  next
    assume Case2: "y  x'" hence "qFresh xs y X'" using yEqFresh by blast
    then obtain Y' where "X' #= Y'" and "qAFresh xs y Y'"
    using good' qFresh_imp_ex_qAFresh1 by fastforce
    thus ?thesis by auto
  qed
  then obtain Y' where alphaX'Y': "X' #= Y'" and
                       yEqAFresh': "y = x'  qAFresh xs y Y'" by blast
  hence "(X' #[[y  x']]_xs) #= (Y' #[[y  x']]_xs)"
  using good' by (auto simp add: qSwap_preserves_alpha)
  hence "(Y #[[y  x]]_xs) #= (Y' #[[y  x']]_xs)"
  using goodYyx alphaYXyx alphaXX'yx alpha_trans by blast
  hence "alphaAbs_ex_equal_or_qAFresh xs x Y xs x' Y'"
  unfolding alphaAbs_ex_equal_or_qAFresh_def using yEqAFresh yEqAFresh' by fastforce
  hence "qAbs xs x Y $= qAbs xs x' Y'"
  using goodY alphaAbs_qAbs_iff_alphaAbs_ex_equal_or_qAFresh[of Y xs x xs] by fastforce
  moreover have "qAbs xs x X $= qAbs xs x Y"
  using alphaXY GOOD qAbs_preserves_alpha by fastforce
  moreover
  {have 1: "Y' #= X'" using alphaX'Y' alpha_sym by auto
   hence "qGood Y'" using good' alpha_preserves_qGood by auto
   hence "qAbs xs x' Y' $= qAbs xs x' X'"
   using 1 GOOD qAbs_preserves_alpha by fastforce
  }
  moreover have "qGoodAbs(qAbs xs x X)" using GOOD by simp
  ultimately have "qAbs xs x X $= qAbs xs x' X'"
  using alphaAbs_trans_twice by blast
  thus ?thesis using xs by simp
qed

lemma alphaAbs_qAbs_iff_alphaAbs_ex_equal_or_qFresh:
assumes GOOD: "qGood X"
shows "(qAbs xs x X $= qAbs xs' x' X') =
       alphaAbs_ex_equal_or_qFresh xs x X xs' x' X'"
proof-
  let ?Left = "qAbs xs x X $= qAbs xs' x' X'"
  let ?Middle = "alphaAbs_ex_equal_or_qAFresh xs x X xs' x' X'"
  let ?Right = "alphaAbs_ex_equal_or_qFresh xs x X xs' x' X'"
  have "?Right  ?Left"
  using assms alphaAbs_ex_equal_or_qFresh_imp_alphaAbs_qAbs by blast
  moreover have "?Left  ?Middle"
  using assms alphaAbs_qAbs_iff_alphaAbs_ex_equal_or_qAFresh by blast
  moreover have "?Middle  ?Right" using
  alphaAbs_ex_equal_or_qAFresh_imp_qFresh by fastforce
  ultimately show ?thesis by blast
qed

corollary alphaAbs_qAbs_iff_ex_equal_or_qFresh:
assumes GOOD: "qGood X"
shows "(qAbs xs x X $= qAbs xs' x' X') =
        (xs = xs' 
         ( y. (y = x  qFresh xs y X)  (y = x'  qFresh xs y X') 
               (X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)))"
proof-
  have "(qAbs xs x X $= qAbs xs' x' X') =
        alphaAbs_ex_equal_or_qFresh xs x X xs' x' X'"
  using assms alphaAbs_qAbs_iff_alphaAbs_ex_equal_or_qFresh by blast
  thus ?thesis unfolding alphaAbs_ex_equal_or_qFresh_def .
qed

lemma alphaAbs_qAbs_iff_alphaAbs_ex_qFresh:
assumes GOOD: "qGood X"
shows "(qAbs xs x X $= qAbs xs' x' X') =
       alphaAbs_ex_qFresh xs x X xs' x' X'"
proof-
  let ?Left = "qAbs xs x X $= qAbs xs' x' X'"
  let ?Middle1 = "alphaAbs_ex_qAFresh xs x X xs' x' X'"
  let ?Middle2 = "alphaAbs_ex_equal_or_qFresh xs x X xs' x' X'"
  let ?Right = "alphaAbs_ex_qFresh xs x X xs' x' X'"
  have "?Left  ?Middle1" unfolding alphaAbs_ex_qAFresh_def by auto
  moreover have "?Middle1  ?Right" using alphaAbs_ex_qAFresh_imp_qFresh by fastforce
  moreover have "?Right  ?Middle2"
  unfolding alphaAbs_ex_qFresh_def alphaAbs_ex_equal_or_qFresh_def by auto
  moreover have "?Middle2  ?Left"
  using assms alphaAbs_ex_equal_or_qFresh_imp_alphaAbs_qAbs by fastforce
  ultimately show ?thesis by blast
qed

corollary alphaAbs_qAbs_iff_ex_qFresh:
assumes GOOD: "qGood X"
shows "(qAbs xs x X $= qAbs xs' x' X') =
        (xs = xs' 
         ( y. qFresh xs y X  qFresh xs y X' 
               (X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)))"
proof-
  have "(qAbs xs x X $= qAbs xs' x' X') =
        alphaAbs_ex_qFresh xs x X xs' x' X'"
  using assms alphaAbs_qAbs_iff_alphaAbs_ex_qFresh by blast
  thus ?thesis unfolding alphaAbs_ex_qFresh_def .
qed 

lemma alphaAbs_qAbs_iff_alphaAbs_ex_distinct_qFresh:
assumes GOOD: "qGood X"
shows "(qAbs xs x X $= qAbs xs' x' X') =
       alphaAbs_ex_distinct_qFresh xs x X xs' x' X'"
proof-
  let ?Left = "qAbs xs x X $= qAbs xs' x' X'"
  let ?Middle1 = "alphaAbs_ex_distinct_qAFresh xs x X xs' x' X'"
  let ?Middle2 = "alphaAbs_ex_equal_or_qFresh xs x X xs' x' X'"
  let ?Right = "alphaAbs_ex_distinct_qFresh xs x X xs' x' X'"
  have "?Left  ?Middle1" unfolding alphaAbs_ex_distinct_qAFresh_def by auto
  moreover have "?Middle1  ?Right" using alphaAbs_ex_distinct_qAFresh_imp_qFresh by fastforce
  moreover have "?Right  ?Middle2"
  unfolding alphaAbs_ex_distinct_qFresh_def alphaAbs_ex_equal_or_qFresh_def by auto
  moreover have "?Middle2  ?Left"
  using assms alphaAbs_ex_equal_or_qFresh_imp_alphaAbs_qAbs by fastforce
  ultimately show ?thesis by blast
qed

corollary alphaAbs_qAbs_iff_ex_distinct_qFresh:
assumes GOOD: "qGood X"
shows "(qAbs xs x X $= qAbs xs' x' X') =
        (xs = xs' 
         ( y. y  {x, x'}  qFresh xs y X  qFresh xs y X' 
               (X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)))"
proof-
  have "(qAbs xs x X $= qAbs xs' x' X') =
        alphaAbs_ex_distinct_qFresh xs x X xs' x' X'"
  using assms alphaAbs_qAbs_iff_alphaAbs_ex_distinct_qFresh by blast
  thus ?thesis unfolding alphaAbs_ex_distinct_qFresh_def .
qed

lemma alphaAbs_qAbs_imp_alphaAbs_all_equal_or_qFresh:
assumes "qGood X" and "qAbs xs x X $= qAbs xs' x' X'"
shows "alphaAbs_all_equal_or_qFresh xs x X xs' x' X'"
proof-
  have "qGoodAbs(qAbs xs x X)" using assms by auto
  hence "qGoodAbs(qAbs xs' x' X')" using assms alphaAbs_preserves_qGoodAbs by blast
  hence GOOD: "qGood X  qGood X'" using assms by auto
  have xs: "xs = xs'" using assms by auto
  show ?thesis
  unfolding alphaAbs_all_equal_or_qFresh_def using xs
  proof(intro conjI impI allI, simp)
    fix y
    assume yEqFresh: "(y = x  qFresh xs y X)  (y = x'  qFresh xs y X')"
    have " Y. X #= Y  (y = x  qAFresh xs y Y)"
    proof(cases "y = x")
      assume Case1: "y = x" hence "X #= X" using GOOD alpha_refl by auto
      thus ?thesis using Case1 by fastforce
    next
      assume Case2: "y  x" hence "qFresh xs y X" using yEqFresh by blast
      then obtain Y where "X #= Y" and "qAFresh xs y Y"
      using GOOD qFresh_imp_ex_qAFresh1 by blast
      thus ?thesis by auto
    qed
    then obtain Y where alphaXY: "X #= Y" and yEqAFresh: "y = x  qAFresh xs y Y" by blast
    hence alphaXYyx: "(X #[[y  x]]_xs) #= (Y #[[y  x]]_xs)"
    using GOOD by (auto simp add: qSwap_preserves_alpha)
    have goodY: "qGood Y" using GOOD alphaXY alpha_preserves_qGood by auto
    (*  *)
    have " Y'. X' #= Y'  (y = x'  qAFresh xs y Y')"
    proof(cases "y = x'")
      assume Case1: "y = x'" hence "X' #= X'" using GOOD alpha_refl by auto
      thus ?thesis using Case1 by fastforce
    next
      assume Case2: "y  x'" hence "qFresh xs y X'" using yEqFresh by blast
      then obtain Y' where "X' #= Y'" and "qAFresh xs y Y'"
      using GOOD qFresh_imp_ex_qAFresh1 by blast
      thus ?thesis by auto
    qed
    then obtain Y' where alphaX'Y': "X' #= Y'" and
                         yEqAFresh': "y = x'  qAFresh xs y Y'" by blast
    hence "(X' #[[y  x']]_xs) #= (Y' #[[y  x']]_xs)"
    using GOOD by (auto simp add: qSwap_preserves_alpha)
    hence alphaY'X'yx': "(Y' #[[y  x']]_xs) #= (X' #[[y  x']]_xs)" using alpha_sym by auto
    have goodY': "qGood Y'" using GOOD alphaX'Y' alpha_preserves_qGood by auto
    (*  *)
    have 1: "Y #= X" using alphaXY alpha_sym by auto
    hence "qGood Y" using GOOD alpha_preserves_qGood by auto
    hence 2: "qAbs xs x Y $= qAbs xs x X"
    using 1 GOOD qAbs_preserves_alpha by blast
    moreover have "qAbs xs x' X' $= qAbs xs x' Y'"
    using alphaX'Y' GOOD qAbs_preserves_alpha by blast
    moreover
    {have "qGoodAbs(qAbs xs x X)" using GOOD by simp
     hence "qGoodAbs(qAbs xs x Y)" using 2 alphaAbs_preserves_qGoodAbs by fastforce
    }
    ultimately have "qAbs xs x Y $= qAbs xs x' Y'"
    using assms xs alphaAbs_trans_twice by blast
    hence "alphaAbs_all_equal_or_qAFresh xs x Y xs x' Y'"
    using goodY goodY' alphaAbs_qAbs_iff_alphaAbs_all_equal_or_qAFresh by blast
    hence "(Y #[[y  x]]_xs) #= (Y' #[[y  x']]_xs)"
    unfolding alphaAbs_all_equal_or_qAFresh_def
    using yEqAFresh yEqAFresh' by auto
    moreover have "qGood (X #[[y  x]]_xs)" using GOOD qSwap_preserves_qGood by auto
    ultimately show "(X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)"
    using alphaXYyx alphaY'X'yx' alpha_trans_twice by blast
  qed
qed

corollary alphaAbs_qAbs_imp_all_equal_or_qFresh:
assumes "qGood X" and "(qAbs xs x X $= qAbs xs' x' X')"
shows
"(xs = xs' 
  ( y. (y = x  qFresh xs y X)  (y = x'  qFresh xs y X') 
        (X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)))"
proof-
  have "alphaAbs_all_equal_or_qFresh xs x X xs' x' X'"
  using assms alphaAbs_qAbs_imp_alphaAbs_all_equal_or_qFresh by blast
  thus ?thesis unfolding alphaAbs_all_equal_or_qFresh_def .
qed

lemma alphaAbs_qAbs_iff_alphaAbs_all_equal_or_qFresh:
assumes "qGood X" and "qGood X'"
shows "(qAbs xs x X $= qAbs xs' x' X') =
       alphaAbs_all_equal_or_qFresh xs x X xs' x' X'"
proof-
  let ?Left = "(qAbs xs x X $= qAbs xs' x' X')"
  let ?Middle = "alphaAbs_all_equal_or_qAFresh xs x X xs' x' X'"
  let ?Right = "alphaAbs_all_equal_or_qFresh xs x X xs' x' X'"
  have "?Left  ?Right"
  using assms alphaAbs_qAbs_imp_alphaAbs_all_equal_or_qFresh by blast
  moreover have "?Right  ?Middle"
  using alphaAbs_all_equal_or_qFresh_imp_qAFresh by fastforce
  moreover have "?Middle ==> ?Left"
  using assms alphaAbs_qAbs_iff_alphaAbs_all_equal_or_qAFresh by blast
  ultimately show ?thesis by blast
qed

corollary alphaAbs_qAbs_iff_all_equal_or_qFresh:
assumes "qGood X" and "qGood X'"
shows "(qAbs xs x X $= qAbs xs' x' X') =
       (xs = xs' 
        ( y. (y = x  qFresh xs y X)  (y = x'  qFresh xs y X') 
              (X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)))"
proof-
  have "(qAbs xs x X $= qAbs xs' x' X') =
        alphaAbs_all_equal_or_qFresh xs x X xs' x' X'"
  using assms alphaAbs_qAbs_iff_alphaAbs_all_equal_or_qFresh by blast
  thus ?thesis unfolding alphaAbs_all_equal_or_qFresh_def .
qed

lemma alphaAbs_qAbs_imp_alphaAbs_all_qFresh:
assumes "qGood X" and "qAbs xs x X $= qAbs xs' x' X'"
shows "alphaAbs_all_qFresh xs x X xs' x' X'"
proof-
  let ?Left = "(qAbs xs x X $= qAbs xs' x' X')"
  let ?Middle = "alphaAbs_all_equal_or_qFresh xs x X xs' x' X'"
  let ?Right = "alphaAbs_all_qFresh xs x X xs' x' X'"
  have "?Left  ?Middle"
  using assms alphaAbs_qAbs_imp_alphaAbs_all_equal_or_qFresh by blast
  moreover have "?Middle  ?Right"
  unfolding alphaAbs_all_equal_or_qFresh_def alphaAbs_all_qFresh_def by auto
  ultimately show ?thesis using assms by blast
qed

corollary alphaAbs_qAbs_imp_all_qFresh:
assumes "qGood X" and "(qAbs xs x X $= qAbs xs' x' X')"
shows
"(xs = xs' 
  ( y. qFresh xs y X  qFresh xs y X' 
        (X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)))"
proof-
  have "alphaAbs_all_qFresh xs x X xs' x' X'"
  using assms alphaAbs_qAbs_imp_alphaAbs_all_qFresh by blast
  thus ?thesis unfolding alphaAbs_all_qFresh_def .
qed

lemma alphaAbs_qAbs_iff_alphaAbs_all_qFresh:
assumes "qGood X" and "qGood X'"
shows "(qAbs xs x X $= qAbs xs' x' X') =
       alphaAbs_all_qFresh xs x X xs' x' X'"
proof-
  let ?Left = "(qAbs xs x X $= qAbs xs' x' X')"
  let ?Middle = "alphaAbs_all_qAFresh xs x X xs' x' X'"
  let ?Right = "alphaAbs_all_qFresh xs x X xs' x' X'"
  have "?Left  ?Right"
  using assms alphaAbs_qAbs_imp_alphaAbs_all_qFresh by blast
  moreover have "?Right  ?Middle"
  using alphaAbs_all_qFresh_imp_qAFresh by fastforce
  moreover have "?Middle  ?Left"
  using assms alphaAbs_qAbs_iff_alphaAbs_all_qAFresh by blast
  ultimately show ?thesis by blast
qed

corollary alphaAbs_qAbs_iff_all_qFresh:
assumes "qGood X" and "qGood X'"
shows "(qAbs xs x X $= qAbs xs' x' X') =
       (xs = xs' 
        ( y. qFresh xs y X  qFresh xs y X' 
              (X #[[y  x]]_xs) #= (X' #[[y  x']]_xs)))"
proof-
  have "(qAbs xs x X $= qAbs xs' x' X') =
        alphaAbs_all_qFresh xs x X xs' x' X'"
  using assms alphaAbs_qAbs_iff_alphaAbs_all_qFresh by blast
  thus ?thesis unfolding alphaAbs_all_qFresh_def .
qed

end  (* context FixVars *)

end

Theory QuasiTerms_Environments_Substitution

section ‹Environments and Substitution for Quasi-Terms›

theory QuasiTerms_Environments_Substitution
imports QuasiTerms_PickFresh_Alpha
begin

text‹Inside this theory, since anyway all the interesting properties hold only
modulo alpha, we forget completely about qAFresh and use only qFresh.›

text‹In this section we define, for quasi-terms, parallel substitution according to
{\em environments}.
This is the most general kind of substitution -- an environment, i.e., a partial
map from variables
to quasi-terms, indicates which quasi-term (if any) to be substituted for each
variable; substitution
is then applied to a subject quasi-term and an environment.  In order to ``keep up"
with the notion
of good quasi-term, we define good environments and show that substitution
preserves goodness.  Since,
unlike swapping, substitution does not behave well w.r.t. quasi-terms
(but only w.r.t. terms, i.e., to alpha-equivalence classes),
here we prove the minimum amount of properties required for properly lifting
parallel substitution to terms. Then compositionality properties
of parallel substitution will be proved directly for terms.
›

subsection ‹Environments›

type_synonym ('index,'bindex,'varSort,'var,'opSym)qEnv =
      "'varSort  'var  ('index,'bindex,'varSort,'var,'opSym)qTerm option"

(*********************************************)
context FixVars  (* scope all throughout the file *)
begin

definition qGoodEnv :: "('index,'bindex,'varSort,'var,'opSym)qEnv  bool"
where
"qGoodEnv rho ==
 ( xs. liftAll qGood (rho xs)) 
 ( ys. |{y. rho ys y  None}| <o |UNIV :: 'var set| )"

definition qFreshEnv where
"qFreshEnv zs z rho ==
 rho zs z = None  ( xs. liftAll (qFresh zs z) (rho xs))"

definition alphaEnv where
"alphaEnv =
 {(rho,rho').  xs. sameDom (rho xs) (rho' xs) 
                      liftAll2 (λX X'. X #= X') (rho xs) (rho' xs)}"

abbreviation alphaEnv_abbrev ::
"('index,'bindex,'varSort,'var,'opSym)qEnv 
 ('index,'bindex,'varSort,'var,'opSym)qEnv  bool" (infix "&=" 50)
where
"rho &= rho' == (rho,rho')  alphaEnv"

definition pickQFreshEnv
where
"pickQFreshEnv xs V XS Rho ==
 pickQFresh xs (V  ( rho  Rho. {x. rho xs x  None}))
               (XS  ( rho  Rho. {X.  ys y. rho ys y = Some X}))"

lemma qGoodEnv_imp_card_of_qTerm:
assumes "qGoodEnv rho"
shows "|{X.  y. rho ys y = Some X}| <o |UNIV :: 'var set|"
proof-
  let ?rel = "{(y,X). rho ys y = Some X}"
  let ?Left = "{X.  y. rho ys y = Some X}"
  let ?Left' = "{y.  X. rho ys y = Some X}"
  have " y X X'. (y,X)  ?rel  (y,X')  ?rel  X = X'" by force
  hence "|?Left| ≤o |?Left'|" using card_of_inj_rel[of ?rel] by auto
  moreover have "|?Left'| <o |UNIV :: 'var set|" using assms unfolding qGoodEnv_def by auto
  ultimately show ?thesis using ordLeq_ordLess_trans by blast
qed

lemma qGoodEnv_imp_card_of_qTerm2:
assumes "qGoodEnv rho"
shows "|{X.  ys y. rho ys y = Some X}| <o |UNIV :: 'var set|"
proof-
  let ?Left = "{X.  ys y. rho ys y = Some X}"
  let ?F = "λ ys. {X.  y. rho ys y = Some X}"
  have "?Left = ( ys. ?F ys)" by auto
  moreover have " ys. |?F ys| <o |UNIV :: 'var set|"
  using assms qGoodEnv_imp_card_of_qTerm by auto
  ultimately show ?thesis
  using var_regular_INNER varSort_lt_var_INNER by(force simp add: regular_UNION)
qed

lemma qGoodEnv_iff:
"qGoodEnv rho =
 (( xs. liftAll qGood (rho xs)) 
  ( ys. |{y. rho ys y  None}| <o |UNIV :: 'var set| ) 
  |{X.  ys y. rho ys y = Some X}| <o |UNIV :: 'var set| )"
unfolding qGoodEnv_def apply auto
apply(rule qGoodEnv_imp_card_of_qTerm2) unfolding qGoodEnv_def by simp

lemma alphaEnv_refl:
"qGoodEnv rho  rho &= rho"
using alpha_refl
unfolding alphaEnv_def qGoodEnv_def liftAll_def liftAll2_def sameDom_def by fastforce

lemma alphaEnv_sym:
"rho &= rho'  rho' &= rho"
using alpha_sym unfolding alphaEnv_def liftAll2_def sameDom_def by fastforce

lemma alphaEnv_trans:
assumes good: "qGoodEnv rho" and
        alpha1: "rho &= rho'" and alpha2: "rho' &= rho''"
shows "rho &= rho''"
using assms unfolding alphaEnv_def
apply(auto)
using sameDom_trans apply blast
unfolding liftAll2_def proof(auto)
  fix xs x X X''
  assume rho: "rho xs x = Some X" and rho'': "rho'' xs x = Some X''"
  moreover have "(rho xs x = None) = (rho' xs x = None)"
  using alpha1 unfolding alphaEnv_def sameDom_def by auto
  ultimately obtain X' where rho': "rho' xs x = Some X'" by auto
  hence "X #= X'" using alpha1 rho unfolding alphaEnv_def liftAll2_def by auto
  moreover have "X' #= X''"
  using alpha2 rho' rho'' unfolding alphaEnv_def liftAll2_def by auto
  moreover have "qGood X" using good rho unfolding qGoodEnv_def liftAll_def by auto
  ultimately show "X #= X''" using alpha_trans by blast
qed

lemma pickQFreshEnv_card_of:
assumes Vvar: "|V| <o |UNIV :: 'var set|" and XSvar: "|XS| <o |UNIV :: 'var set|" and
        good: " X  XS. qGood X" and
        Rhovar: "|Rho| <o |UNIV :: 'var set|" and RhoGood: " rho  Rho. qGoodEnv rho"
shows
"pickQFreshEnv xs V XS Rho  V 
 ( X  XS. qFresh xs (pickQFreshEnv xs V XS Rho) X) 
 ( rho  Rho. qFreshEnv xs (pickQFreshEnv xs V XS Rho) rho)"
proof-
  let ?z =" pickQFreshEnv xs V XS Rho"
  let ?V2 = " rho  Rho. {x. rho xs x  None}"  let ?W = "V  ?V2"
  let ?XS2 = " rho  Rho. {X.  ys y. rho ys y = Some X}" let ?YS = "XS  ?XS2"
  have "|?W| <o |UNIV :: 'var set|"
  proof-
    have " rho  Rho. |{x. rho xs x  None}| <o |UNIV :: 'var set|"
    using RhoGood unfolding qGoodEnv_iff using qGoodEnv_iff by auto
    hence "|?V2| <o |UNIV :: 'var set|"
    using var_regular_INNER Rhovar by (auto simp add: regular_UNION)
    thus ?thesis using var_infinite_INNER Vvar card_of_Un_ordLess_infinite by auto
  qed
  moreover have "|?YS| <o |UNIV :: 'var set|"
  proof-
    have " rho  Rho. |{X.  ys y. rho ys y = Some X}| <o |UNIV :: 'var set|"
    using RhoGood unfolding qGoodEnv_iff by auto
    hence "|?XS2| <o |UNIV :: 'var set|"
    using var_regular_INNER Rhovar by (auto simp add: regular_UNION)
    thus ?thesis using var_infinite_INNER XSvar card_of_Un_ordLess_infinite by auto
  qed
  moreover have " Y  ?YS. qGood Y"
  using good RhoGood unfolding qGoodEnv_iff liftAll_def by blast
  ultimately
  have "?z  ?W  ( Y  ?YS. qFresh xs ?z Y)"
  unfolding pickQFreshEnv_def using pickQFresh_card_of[of ?W ?YS] by auto
  thus ?thesis unfolding qFreshEnv_def liftAll_def by(auto)
qed

lemma pickQFreshEnv:
assumes Vvar: "|V| <o |UNIV :: 'var set|  finite V"
and XSvar: "|XS| <o |UNIV :: 'var set|  finite XS"
and good: " X  XS. qGood X"
and Rhovar: "|Rho| <o |UNIV :: 'var set|  finite Rho"
and RhoGood: " rho  Rho. qGoodEnv rho"
shows
"pickQFreshEnv xs V XS Rho  V 
 ( X  XS. qFresh xs (pickQFreshEnv xs V XS Rho) X) 
 ( rho  Rho. qFreshEnv xs (pickQFreshEnv xs V XS Rho) rho)"
proof-
  have 1: "|V| <o |UNIV :: 'var set|  |XS| <o |UNIV :: 'var set|  |Rho| <o |UNIV :: 'var set|"
  using assms var_infinite_INNER by(auto simp add: finite_ordLess_infinite2)
  show ?thesis
  apply(rule pickQFreshEnv_card_of)
  using assms 1 by auto
qed

corollary obtain_qFreshEnv:
fixes XS::"('index,'bindex,'varSort,'var,'opSym)qTerm set" and
      Rho::"('index,'bindex,'varSort,'var,'opSym)qEnv set" and rho
assumes Vvar: "|V| <o |UNIV :: 'var set|  finite V"
and XSvar: "|XS| <o |UNIV :: 'var set|  finite XS"
and good: " X  XS. qGood X"
and Rhovar: "|Rho| <o |UNIV :: 'var set|  finite Rho"
and RhoGood: " rho  Rho. qGoodEnv rho"
shows
" z. z  V 
 ( X  XS. qFresh xs z X)  ( rho  Rho. qFreshEnv xs z rho)"
apply(rule exI[of _ "pickQFreshEnv xs V XS Rho"])
using assms by(rule pickQFreshEnv)

subsection ‹Parallel substitution›

(* I shall prove only a *minimal* collection of facts for quasi-
[parallel substitution], just enough
  to show that substitution preserves alpha.  The other properties shall be proved
  for alpha-equivalence directly.   *)

definition aux_qPsubst_ignoreFirst ::
"('index,'bindex,'varSort,'var,'opSym)qEnv * ('index,'bindex,'varSort,'var,'opSym)qTerm +
 ('index,'bindex,'varSort,'var,'opSym)qEnv * ('index,'bindex,'varSort,'var,'opSym)qAbs
  ('index,'bindex,'varSort,'var,'opSym)qTermItem"
where
"aux_qPsubst_ignoreFirst K ==
 case K of Inl (rho,X)  termIn X
          |Inr (rho,A)  absIn A"

lemma aux_qPsubst_ignoreFirst_qTermLessQSwapped_wf:
"wf(inv_image qTermQSwappedLess aux_qPsubst_ignoreFirst)"
using qTermQSwappedLess_wf wf_inv_image by auto

function
qPsubst ::
"('index,'bindex,'varSort,'var,'opSym)qEnv  ('index,'bindex,'varSort,'var,'opSym)qTerm 
 ('index,'bindex,'varSort,'var,'opSym)qTerm"
and
qPsubstAbs ::
"('index,'bindex,'varSort,'var,'opSym)qEnv  ('index,'bindex,'varSort,'var,'opSym)qAbs 
 ('index,'bindex,'varSort,'var,'opSym)qAbs"
where
"qPsubst rho (qVar xs x) = (case rho xs x of None  qVar xs x| Some X  X)"
|
"qPsubst rho (qOp delta inp binp) =
 qOp delta (lift (qPsubst rho) inp) (lift (qPsubstAbs rho) binp)"
|
"qPsubstAbs rho (qAbs xs x X) =
 (let x' = pickQFreshEnv xs {x} {X} {rho} in qAbs xs x' (qPsubst rho (X #[[x'  x]]_xs)))"
by(pat_completeness, auto)
termination
apply(relation "inv_image qTermQSwappedLess aux_qPsubst_ignoreFirst")
apply(simp add: aux_qPsubst_ignoreFirst_qTermLessQSwapped_wf)
by(auto simp add: qTermQSwappedLess_def qTermLess_modulo_def
   aux_qPsubst_ignoreFirst_def qSwap_qSwapped)

abbreviation qPsubst_abbrev ::
"('index,'bindex,'varSort,'var,'opSym)qTerm  ('index,'bindex,'varSort,'var,'opSym)qEnv 
 ('index,'bindex,'varSort,'var,'opSym)qTerm" ("_ #[[_]]")
where "X #[[rho]] == qPsubst rho X"

abbreviation qPsubstAbs_abbrev ::
"('index,'bindex,'varSort,'var,'opSym)qAbs  ('index,'bindex,'varSort,'var,'opSym)qEnv 
 ('index,'bindex,'varSort,'var,'opSym)qAbs" ("_ $[[_]]")
where "A $[[rho]] == qPsubstAbs rho A"

lemma qPsubstAll_preserves_qGoodAll:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs" and rho
assumes GOOD_ENV: "qGoodEnv rho"
shows
"(qGood X  qGood (X #[[rho]]))  (qGoodAbs A  qGoodAbs (A $[[rho]]))"
proof(induction rule: qTerm_induct[of _ _ X A])
  case (Var xs x)
  show ?case 
  using GOOD_ENV unfolding qGoodEnv_iff liftAll_def
  by(cases "rho xs x", auto)
next
  case (Op delta inp binp)
  show ?case proof safe
    assume g: "qGood (qOp delta inp binp)"
    hence 0: "liftAll qGood (lift (qPsubst rho) inp)  
              liftAll qGoodAbs (lift (qPsubstAbs rho) binp)"
    using Op unfolding liftAll_lift_comp comp_def
    by (simp_all add: Let_def liftAll_mp)
    have "{i. lift (qPsubst rho) inp i  None} = {i. inp i  None}  
     {i. lift (qPsubstAbs rho) binp i  None} = {i. binp i  None}"
    by simp (meson lift_Some)
    hence "|{i. y. lift (qPsubst rho) inp i = Some y}| <o |UNIV:: 'var set|" 
    and "|{i. y. lift (qPsubstAbs rho) binp i = Some y}| <o |UNIV:: 'var set|"
    using g by (auto simp: liftAll_def)
    thus "qGood qOp delta inp binp #[[rho]]" using 0 by simp
  qed
next
  case (Abs xs x X)
  show ?case proof safe
    assume g: "qGoodAbs (qAbs xs x X)"      
    let ?x' = "pickQFreshEnv xs {x} {X} {rho}"  let ?X' = "X #[[?x'  x]]_xs"
    have "qGood ?X'" using g qSwap_preserves_qGood by auto
    moreover have "(X,?X')  qSwapped" using qSwap_qSwapped by fastforce
    ultimately have "qGood (qPsubst rho ?X')" using Abs.IH by simp
    thus "qGoodAbs ((qAbs xs x X) $[[rho]])" by (simp add: Let_def)
  qed
qed 

corollary qPsubst_preserves_qGood:
"qGoodEnv rho; qGood X  qGood (X #[[rho]])"
using qPsubstAll_preserves_qGoodAll by auto

corollary qPsubstAbs_preserves_qGoodAbs:
"qGoodEnv rho; qGoodAbs A  qGoodAbs (A $[[rho]])"
using qPsubstAll_preserves_qGoodAll by auto

lemma qPsubstAll_preserves_qFreshAll:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs" and rho
assumes GOOD_ENV: "qGoodEnv rho"
shows
"(qFresh zs z X 
  (qGood X  qFreshEnv zs z rho  qFresh zs z (X #[[rho]]))) 
 (qFreshAbs zs z A 
  (qGoodAbs A  qFreshEnv zs z rho  qFreshAbs zs z (A $[[rho]])))"
proof(induction rule: qTerm_induct[of _ _ X A])
  case (Var xs x)
  then show ?case
  unfolding qFreshEnv_def liftAll_def by (cases "rho xs x") auto 
next
  case (Op delta inp binp)
  thus ?case 
  by (auto simp add: lift_def liftAll_def qFreshEnv_def split: option.splits)
next 
  case (Abs xs x X)
  show ?case proof safe
    assume q: "qFreshAbs zs z (qAbs xs x X)"
    "qGoodAbs (qAbs xs x X)" "qFreshEnv zs z rho"
    let ?x' = "pickQFreshEnv xs {x} {X} {rho}"  let ?X' = "X #[[?x'  x]]_xs"
    have x': "qFresh xs ?x' X  qFreshEnv xs ?x' rho"
    using q GOOD_ENV by(auto simp add: pickQFreshEnv)
    hence goodX': "qGood ?X'" using q qSwap_preserves_qGood by auto
    have XX': "(X,?X')  qSwapped" using qSwap_qSwapped by fastforce
    have  "(zs = xs  z = ?x')  qFresh zs z (qPsubst rho ?X')"
    by (meson qSwap_preserves_qFresh_distinct 
    Abs.IH(1) XX' goodX' q qAbs_alphaAbs_qSwap_qFresh qFreshAbs.simps 
    qFreshAbs_preserves_alphaAbs1 qSwap_preserves_qGood2 x')
    thus "qFreshAbs zs z ((qAbs xs x X) $[[rho]])"
    by simp (meson qFreshAbs.simps)+ 
  qed
qed

lemma qPsubst_preserves_qFresh:
"qGood X; qGoodEnv rho; qFresh zs z X; qFreshEnv zs z rho
  qFresh zs z (X #[[rho]])"
by(simp add: qPsubstAll_preserves_qFreshAll)

lemma qPsubstAbs_preserves_qFreshAbs:
"qGoodAbs A; qGoodEnv rho; qFreshAbs zs z A; qFreshEnv zs z rho
  qFreshAbs zs z (A $[[rho]])"
by(simp add: qPsubstAll_preserves_qFreshAll)

text‹While in general we try to avoid proving facts in parallel,
   here we seem to have no choice -- it is the first time we must use mutual 
induction:›

lemma qPsubstAll_preserves_alphaAll_qSwapAll:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs" and
      rho::"('index,'bindex,'varSort,'var,'opSym)qEnv"
assumes goodRho: "qGoodEnv rho"
shows
"(qGood X 
  ( Y. X #= Y  (X #[[rho]]) #= (Y #[[rho]])) 
  ( xs z1 z2. qFreshEnv xs z1 rho  qFreshEnv xs z2 rho 
               ((X #[[z1  z2]]_xs) #[[rho]]) #= ((X #[[rho]]) #[[z1  z2]]_xs))) 
 (qGoodAbs A 
  ( B. A $= B  (A $[[rho]]) $= (B $[[rho]])) 
  ( xs z1 z2. qFreshEnv xs z1 rho  qFreshEnv xs z2 rho 
               ((A $[[z1  z2]]_xs) $[[rho]]) $= ((A $[[rho]]) $[[z1  z2]]_xs)))"
proof(induction rule: qGood_qTerm_induct_mutual)
  case (Var1 xs x)
  then show ?case  
  by (metis alpha_refl goodRho qGood.simps(1) qPsubst_preserves_qGood qVar_alpha_iff)
next
  case (Var2 xs x)
  show ?case proof safe
    fix s::'sort and zs z1 z2
    assume FreshEnv: "qFreshEnv zs z1 rho" "qFreshEnv zs z2 rho"
    hence n: "rho zs z1 = None  rho zs z2 = None" unfolding qFreshEnv_def by simp
    let ?Left = "qPsubst rho ((qVar xs x) #[[z1  z2]]_zs)"
    let ?Right = "(qPsubst rho (qVar xs x)) #[[z1  z2]]_zs"
    have "qGood (qVar xs x)" by simp
    hence "qGood ((qVar xs x) #[[z1  z2]]_zs)"
    using qSwap_preserves_qGood by blast
    hence goodLeft: "qGood ?Left" using goodRho qPsubst_preserves_qGood by blast
    show "?Left #= ?Right"
    proof(cases "rho xs x")  
      case None
      hence "rho xs (x @xs[z1  z2]_zs) = None"
      using n unfolding sw_def by auto
      thus ?thesis using None by simp
    next
      case (Some X) 
      hence "xs  zs  x  {z1,z2}" using n by auto
      hence "(x @xs[z1  z2]_zs) = x" unfolding sw_def by auto
      moreover
      {have "qFresh zs z1 X  qFresh zs z2 X"
       using Some FreshEnv unfolding qFreshEnv_def liftAll_def by auto
       moreover have "qGood X" using Some goodRho unfolding qGoodEnv_def liftAll_def by auto
       ultimately have "X #= (X #[[z1  z2]]_zs)"
       by(auto simp: alpha_qFresh_qSwap_id alpha_sym)
      }
      ultimately show ?thesis using Some by simp
    qed
  qed
next
  case (Op1 delta inp binp)
  show ?case proof safe
    fix Y assume q: "qOp delta inp binp #= Y" 
    then obtain inp' binp' where Y: "Y = qOp delta inp' binp'" and
       *: "(i. (inp i = None) = (inp' i = None)) 
           (i. (binp i = None) = (binp' i = None))" and
       **: "(i X X'. inp i = Some X  inp' i = Some X'  X #= X') 
            (i A A'. binp i = Some A  binp' i = Some A'  A $= A')"
    unfolding qOp_alpha_iff sameDom_def liftAll2_def by auto
    show "(qOp delta inp binp) #[[rho]] #= (Y #[[rho]])"  
    using Op1 **
    by (simp add: Y sameDom_def liftAll2_def)
       (fastforce simp add: * lift_None lift_Some 
        liftAll_def lift_def split: option.splits)
  qed
next
  case (Op2 delta inp binp)
  thus ?case  
  by (auto simp: sameDom_def liftAll2_def lift_None lift_def liftAll_def split: option.splits)  
next
  case (Abs1 xs x X)
  show ?case proof safe
    fix B
    assume alpha_xXB: "qAbs xs x X $= B"
    then obtain y Y where B: "B = qAbs xs y Y" unfolding qAbs_alphaAbs_iff by auto  
    have "qGoodAbs B" using ‹qGood X alpha_xXB alphaAbs_preserves_qGoodAbs by force
    hence goodY: "qGood Y" unfolding B by simp
    let ?x' = "pickQFreshEnv xs {x} {X} {rho}"
    let ?y' = "pickQFreshEnv xs {y} {Y} {rho}"
    obtain x' and y' where x'y'_def: "x' = ?x'" "y' = ?y'" and
           x'y'_rev: "?x' = x'" "?y' = y'" by blast
    have x'y'_freshXY: "qFresh xs x' X  qFresh xs y' Y"
    unfolding x'y'_def using ‹qGood X goodY goodRho by (auto simp add: pickQFreshEnv)
    have x'y'_fresh_rho: "qFreshEnv xs x' rho  qFreshEnv xs y' rho"
    unfolding x'y'_def using ‹qGood X goodY goodRho by (auto simp add: pickQFreshEnv)
    have x'y'_not_xy: "x'  x  y'  y"
    unfolding x'y'_def using ‹qGood X goodY goodRho
    using pickQFreshEnv[of "{x}" "{X}"] pickQFreshEnv[of "{y}" "{Y}"] by force
    have goodXx'x: "qGood (X #[[x'  x]]_xs)" using ‹qGood X qSwap_preserves_qGood by auto
    hence good: "qGood(qPsubst rho (X #[[x'  x]]_xs))"
    using goodRho qPsubst_preserves_qGood by auto
    have goodYy'y: "qGood (Y #[[y'  y]]_xs)" using goodY qSwap_preserves_qGood by auto
    obtain z where z_not: "z  {x,y,x',y'}" and
    z_fresh_XY: "qFresh xs z X  qFresh xs z Y"
    and z_fresh_rho: "qFreshEnv xs z rho" using ‹qGood X goodY goodRho
    using obtain_qFreshEnv[of "{x,y,x',y'}" "{X,Y}" "{rho}"] by auto
    (* Notations: *)
    let ?Xx'x = "X #[[x'  x]]_xs"   let ?Yy'y = "Y #[[y'  y]]_xs"
    let ?Xx'xzx' = "?Xx'x #[[z  x']]_xs" let ?Yy'yzy' = "?Yy'y #[[z  y']]_xs"
    let ?Xzx = "X #[[z  x]]_xs"   let ?Yzy = "Y #[[z  y]]_xs"
    (* Preliminary facts: *)
    have goodXx'x: "qGood ?Xx'x" using ‹qGood X qSwap_preserves_qGood by auto
    hence goodXx'xzx': "qGood ?Xx'xzx'" using qSwap_preserves_qGood by auto
    have "qGood (?Xx'x #[[rho]])" using goodXx'x goodRho qPsubst_preserves_qGood by auto
    hence goodXx'x_rho_zx': "qGood ((?Xx'x #[[rho]]) #[[z  x']]_xs)"
    using qSwap_preserves_qGood by auto
    have goodYy'y: "qGood ?Yy'y" using goodY qSwap_preserves_qGood by auto
    (*  *)
    have skelXx'x: "qSkel ?Xx'x = qSkel X" using qSkel_qSwap by fastforce
    hence skelXx'xzx': "qSkel ?Xx'xzx' = qSkel X" by (auto simp add: qSkel_qSwap)
    have "qSkelAbs B = qSkelAbs (qAbs xs x X)"
    using alpha_xXB alphaAll_qSkelAll by fastforce
    hence "qSkel Y = qSkel X" unfolding B by(auto simp add: fun_eq_iff)
    hence skelYy'y: "qSkel ?Yy'y = qSkel X" by(auto simp add: qSkel_qSwap)
    (* Main proof: *)
    have "((?Xx'x #[[rho]]) #[[z  x']]_xs) #= (?Xx'xzx' #[[rho]])"
    using skelXx'x goodXx'x z_fresh_rho x'y'_fresh_rho
          Abs1.IH(2)[of "?Xx'x"] by (auto simp add: alpha_sym)
    moreover
    {have "?Xx'xzx' #= ?Xzx"
     using ‹qGood X x'y'_freshXY z_fresh_XY alpha_qFresh_qSwap_compose by fastforce
     moreover have "?Xzx #= ?Yzy" using alpha_xXB unfolding B
     using z_fresh_XY ‹qGood X goodY
     by (simp only: alphaAbs_qAbs_iff_all_qFresh)
     moreover have "?Yzy #= ?Yy'yzy'" using goodY x'y'_freshXY z_fresh_XY
     by(auto simp add: alpha_qFresh_qSwap_compose alpha_sym)
     ultimately have "?Xx'xzx' #= ?Yy'yzy'" using goodXx'xzx' alpha_trans by blast
     hence "(?Xx'xzx' #[[rho]]) #= (?Yy'yzy' #[[rho]])"
     using goodXx'xzx' skelXx'xzx' Abs1.IH(1) by auto
    }  
    moreover have "(?Yy'yzy' #[[rho]]) #= ((?Yy'y #[[rho]]) #[[z  y']]_xs)"
    using skelYy'y goodYy'y z_fresh_rho x'y'_fresh_rho
          Abs1.IH(2)[of "?Yy'y"] alpha_sym by fastforce
    ultimately
    have "((?Xx'x #[[rho]]) #[[z  x']]_xs) #= ((?Yy'y #[[rho]]) #[[z  y']]_xs)"
    using goodXx'x_rho_zx' alpha_trans by blast  
    thus "(qAbs xs x X) $[[rho]] $= (B $[[rho]])"
    unfolding B apply simp unfolding Let_def 
    unfolding x'y'_rev
    using good z_not apply(simp only: alphaAbs_qAbs_iff_ex_qFresh)
    by (auto intro!: exI[of _ z]
    simp: alphaAbs_qAbs_iff_ex_qFresh goodRho goodXx'x qPsubstAll_preserves_qFreshAll 
    qSwap_preserves_qFresh_distinct z_fresh_XY goodYy'y qPsubst_preserves_qFresh z_fresh_rho)
  qed 
next
  case (Abs2 xs x X)
  show ?case proof safe 
    fix zs z1 z2
    assume z1z2_fresh_rho: "qFreshEnv zs z1 rho" "qFreshEnv zs z2 rho" 
    let ?x' = "pickQFreshEnv xs {x @xs[z1  z2]_zs} {X #[[z1  z2]]_zs} {rho}"
    let ?x'' = "pickQFreshEnv xs {x} {X} {rho}"
    obtain x' x'' where x'x''_def: "x' = ?x'" "x'' = ?x''" and
           x'x''_rev: "?x' = x'" "?x'' = x''" by blast
    let ?xa = "x @xs[z1  z2]_zs"  let ?xa'' = "x'' @xs[z1  z2]_zs"
    obtain u where "u  {x,x',x'',z1,z2}" and
    u_fresh_X: "qFresh xs u X" and u_fresh_rho: "qFreshEnv xs u rho"
    using ‹qGood X goodRho using obtain_qFreshEnv[of "{x,x',x'',z1,z2}" "{X}" "{rho}"] by auto
    hence u_not: "u  {x,x',x'',z1,z2,?xa,?xa''}" unfolding sw_def by auto
    let ?ua = "u @xs [z1  z2]_zs"
    let ?Xz1z2 = "X #[[z1  z2]]_zs"  
      let ?Xz1z2x'xa = "?Xz1z2 #[[x'  ?xa]]_xs"
        let ?Xz1z2x'xa_rho = "?Xz1z2x'xa #[[rho]]"
          let ?Xz1z2x'xa_rho_ux' = "?Xz1z2x'xa_rho #[[u  x']]_xs"
        let ?Xz1z2x'xaux' = "?Xz1z2x'xa #[[u  x']]_xs"
          let ?Xz1z2x'xaux'_rho = "?Xz1z2x'xaux' #[[rho]]"
      let ?Xz1z2uxa = "?Xz1z2 #[[u  ?xa]]_xs"
      let ?Xz1z2uaxa = "?Xz1z2 #[[?ua  ?xa]]_xs"
    let ?Xux = "X #[[u  x]]_xs"
      let ?Xuxz1z2 = "?Xux #[[z1  z2]]_zs"
    let ?Xx''x = "X #[[x''  x]]_xs"
      let ?Xx''xux'' = "?Xx''x #[[u  x'']]_xs"
        let ?Xx''xux''z1z2 = "?Xx''xux'' #[[z1  z2]]_zs"
      let ?Xx''xz1z2 = "?Xx''x #[[z1  z2]]_zs"
        let ?Xx''xz1z2uaxa'' = "?Xx''xz1z2 #[[?ua  ?xa'']]_xs"
          let ?Xx''xz1z2uaxa''_rho = "?Xx''xz1z2uaxa'' #[[rho]]"
        let ?Xx''xz1z2uxa'' = "?Xx''xz1z2 #[[u  ?xa'']]_xs"
          let ?Xx''xz1z2uxa''_rho = "?Xx''xz1z2uxa'' #[[rho]]"
        let ?Xx''xz1z2_rho = "?Xx''xz1z2 #[[rho]]"
          let ?Xx''xz1z2_rho_uxa'' = "?Xx''xz1z2_rho #[[u  ?xa'']]_xs"
      let ?Xx''x_rho = "?Xx''x #[[rho]]"
        let ?Xx''x_rho_z1z2 = "?Xx''x_rho #[[z1  z2]]_zs"
          let ?Xx''x_rho_z1z2uxa'' = "?Xx''x_rho_z1z2 #[[u  ?xa'']]_xs"
    (* Facts about x', x'', ?xa, ?ua, ?xa'': *)
    have goodXz1z2: "qGood ?Xz1z2" using ‹qGood X qSwap_preserves_qGood by auto
    have x'x''_fresh_Xz1z2: "qFresh xs x' ?Xz1z2  qFresh xs x'' X"
    unfolding x'x''_def using ‹qGood X goodXz1z2 goodRho by (auto simp add: pickQFreshEnv)
    have x'x''_fresh_rho: "qFreshEnv xs x' rho  qFreshEnv xs x'' rho"
    unfolding x'x''_def using ‹qGood X goodXz1z2 goodRho by (auto simp add: pickQFreshEnv)
    have ua_eq_u: "?ua = u" using u_not unfolding sw_def by auto
    (* Good: *)
    have goodXz1z2x'xa: "qGood ?Xz1z2x'xa" using goodXz1z2 qSwap_preserves_qGood by auto
    have goodXux: "qGood ?Xux" using ‹qGood X qSwap_preserves_qGood by auto
    hence goodXuxz1z2: "qGood ?Xuxz1z2" using qSwap_preserves_qGood by auto
    have goodXx''x: "qGood ?Xx''x" using ‹qGood X qSwap_preserves_qGood by auto
    hence goodXx''xz1z2: "qGood ?Xx''xz1z2" using qSwap_preserves_qGood by auto
    hence "qGood ?Xx''xz1z2_rho" using goodRho qPsubst_preserves_qGood by auto
    hence goodXx''xz1z2_rho: "qGood ?Xx''xz1z2_rho"
    using goodRho qPsubst_preserves_qGood by auto
    have goodXz1z2x'xaux': "qGood ?Xz1z2x'xaux'"
    using goodXz1z2x'xa qSwap_preserves_qGood by auto
    have goodXz1z2x'xa_rho: "qGood ?Xz1z2x'xa_rho"
    using goodXz1z2x'xa goodRho qPsubst_preserves_qGood by auto
    hence goodXz1z2x'xa_rho_ux': "qGood ?Xz1z2x'xa_rho_ux'"
    using qSwap_preserves_qGood by auto
    (* Fresh: *)
    have xa''_fresh_rho: "qFreshEnv xs ?xa'' rho"
    using x'x''_fresh_rho z1z2_fresh_rho unfolding sw_def by auto
    have u_fresh_Xz1z2: "qFresh xs u ?Xz1z2"
    using u_fresh_X u_not by(auto simp add: qSwap_preserves_qFresh_distinct)
    hence "qFresh xs u ?Xz1z2x'xa" using u_not by(auto simp add: qSwap_preserves_qFresh_distinct)
    hence u_fresh_Xz1z2x'xa_rho: "qFresh xs u ?Xz1z2x'xa_rho"
    using u_fresh_rho u_fresh_X goodRho goodXz1z2x'xa qPsubst_preserves_qFresh by auto
    have "qFresh xs u ?Xx''x"
    using u_fresh_X u_not by(auto simp add: qSwap_preserves_qFresh_distinct)
    hence "qFresh xs u ?Xx''x_rho" using goodRho goodXx''x u_fresh_rho
    by(auto simp add: qPsubst_preserves_qFresh)
    hence u_fresh_Xx''x_rho_z1z2: "qFresh xs u ?Xx''x_rho_z1z2"
    using u_not by(auto simp add: qSwap_preserves_qFresh_distinct)
    (* Skeleton: *)
    have skel_Xz1z2x'xa: "qSkel ?Xz1z2x'xa = qSkel X" by(auto simp add: qSkel_qSwap)
    hence skel_Xz1z2x'xaux': "qSkel ?Xz1z2x'xaux' = qSkel X" by(auto simp add: qSkel_qSwap)
    have skel_Xx''x: "qSkel ?Xx''x = qSkel X" by(auto simp add: qSkel_qSwap)
    hence skel_Xx''xz1z2: "qSkel ?Xx''xz1z2 = qSkel X" by(auto simp add: qSkel_qSwap)
    (* Main proof: *)     
    have "?Xz1z2x'xaux'_rho #= ?Xz1z2x'xa_rho_ux'"
    using x'x''_fresh_rho u_fresh_rho skel_Xz1z2x'xa goodXz1z2x'xa
    using Abs2.IH(2)[of ?Xz1z2x'xa] by auto
    hence "?Xz1z2x'xa_rho_ux' #= ?Xz1z2x'xaux'_rho" using alpha_sym by auto
    moreover
    {have "?Xz1z2x'xaux' #= ?Xz1z2uxa"
     using goodXz1z2 u_fresh_Xz1z2 x'x''_fresh_Xz1z2
     using alpha_qFresh_qSwap_compose by fastforce
     moreover have "?Xz1z2uxa = ?Xuxz1z2"
     using ua_eq_u qSwap_compose[of zs z1 z2 xs x u X] by(auto simp: qSwap_sym)
     moreover
     {have "?Xux #= ?Xx''xux''"
      using ‹qGood X u_fresh_X x'x''_fresh_Xz1z2
      by(auto simp: alpha_qFresh_qSwap_compose alpha_sym)
      hence "?Xuxz1z2 #= ?Xx''xux''z1z2"
      using goodXux by (auto simp add: qSwap_preserves_alpha)
     }
     moreover have "?Xx''xux''z1z2 = ?Xx''xz1z2uxa''"
     using ua_eq_u qSwap_compose[of zs z1 z2 _  _ _ ?Xx''x] by auto
     ultimately have "?Xz1z2x'xaux' #= ?Xx''xz1z2uxa''"
     using goodXz1z2x'xaux' alpha_trans by auto
     hence "?Xz1z2x'xaux'_rho #= ?Xx''xz1z2uxa''_rho"
     using goodXz1z2x'xaux' skel_Xz1z2x'xaux' Abs2.IH(1) by auto
    }
    moreover have "?Xx''xz1z2uxa''_rho #= ?Xx''xz1z2_rho_uxa''"
    using xa''_fresh_rho u_fresh_rho skel_Xx''xz1z2 goodXx''xz1z2
    using Abs2.IH(2)[of ?Xx''xz1z2] by auto
    moreover
    {have "?Xx''xz1z2_rho #= ?Xx''x_rho_z1z2"
     using z1z2_fresh_rho skel_Xx''x goodXx''x
     using Abs2.IH(2)[of ?Xx''x] by auto
     hence "?Xx''xz1z2_rho_uxa'' #= ?Xx''x_rho_z1z2uxa''"
     using goodXx''xz1z2_rho by(auto simp add: qSwap_preserves_alpha)
    }
    ultimately have "?Xz1z2x'xa_rho_ux' #= ?Xx''x_rho_z1z2uxa''"
    using goodXz1z2x'xa_rho_ux' alpha_trans by blast
    thus "((qAbs xs x X) $[[z1  z2]]_zs) $[[rho]] $= 
          (((qAbs xs x X) $[[rho]]) $[[z1  z2]]_zs)"
    using goodXz1z2x'xa_rho    
    goodXz1z2x'xa u_not u_fresh_Xz1z2x'xa_rho u_fresh_Xx''x_rho_z1z2 
    apply(simp add: Let_def x'x''_rev del: alpha.simps alphaAbs.simps ) 
    by (auto simp only: Let_def alphaAbs_qAbs_iff_ex_qFresh)
  qed
qed

corollary qPsubst_preserves_alpha1:
assumes "qGoodEnv rho" and "qGood X  qGood Y" and "X #= Y"
shows "(X #[[rho]]) #= (Y #[[rho]])"
using alpha_preserves_qGood assms qPsubstAll_preserves_alphaAll_qSwapAll by blast
 
corollary qPsubstAbs_preserves_alphaAbs1:
assumes "qGoodEnv rho" and "qGoodAbs A  qGoodAbs B" and "A $= B"
shows "(A $[[rho]]) $= (B $[[rho]])"
using alphaAbs_preserves_qGoodAbs assms qPsubstAll_preserves_alphaAll_qSwapAll by blast

corollary alpha_qFreshEnv_qSwap_qPsubst_commute:
"qGoodEnv rho; qGood X; qFreshEnv zs z1 rho; qFreshEnv zs z2 rho 
 ((X #[[z1  z2]]_zs) #[[rho]]) #= ((X #[[rho]]) #[[z1  z2]]_zs)"
by(simp add: qPsubstAll_preserves_alphaAll_qSwapAll)

corollary alphaAbs_qFreshEnv_qSwapAbs_qPsubstAbs_commute:
"qGoodEnv rho; qGoodAbs A;
  qFreshEnv zs z1 rho; qFreshEnv zs z2 rho 
 ((A $[[z1  z2]]_zs) $[[rho]]) $= ((A $[[rho]]) $[[z1  z2]]_zs)"
by(simp add: qPsubstAll_preserves_alphaAll_qSwapAll)

lemma qPsubstAll_preserves_alphaAll2:
fixes X::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      A::"('index,'bindex,'varSort,'var,'opSym)qAbs" and
      rho'::"('index,'bindex,'varSort,'var,'opSym)qEnv" and rho''
assumes rho'_alpha_rho'': "rho' &= rho''" and
        goodRho': "qGoodEnv rho'" and goodRho'': "qGoodEnv rho''"
shows
"(qGood X  (X #[[rho']]) #= (X #[[rho'']])) 
 (qGoodAbs A  (A $[[rho']]) $= (A $[[rho'']]))"
proof(induction rule: qGood_qTerm_induct)
  case (Var xs x)
  then show ?case 
  proof (cases "rho' xs x") 
    case None
    hence "rho'' xs x = None" using rho'_alpha_rho'' unfolding alphaEnv_def sameDom_def by auto
    thus ?thesis using None by simp
  next
    case (Some X')
    then obtain X'' where rho'': "rho'' xs x = Some X''"
    using assms unfolding alphaEnv_def sameDom_def by force
    hence "X' #= X''" using Some rho'_alpha_rho''
    unfolding alphaEnv_def liftAll2_def by auto
    thus ?thesis using Some rho'' by simp
  qed 
next
  case (Op delta inp binp)
  then show ?case 
  by (auto simp: lift_def liftAll_def liftAll2_def sameDom_def Let_def
      split: option.splits)
next
  case (Abs xs x X)   
  let ?x' = "pickQFreshEnv xs {x} {X} {rho'}"
  let ?x'' = "pickQFreshEnv xs {x} {X} {rho''}"
  obtain x' x'' where x'x''_def: "x' = ?x'" "x'' = ?x''" and
          x'x''_rev: "?x' = x'" "?x'' = x''" by blast
  have x'x''_fresh_X: "qFresh xs x' X  qFresh xs x'' X"
  unfolding x'x''_def using ‹qGood X goodRho' goodRho'' by (auto simp add: pickQFreshEnv)
  have x'_fresh_rho': "qFreshEnv xs x' rho'"
  unfolding x'x''_def using ‹qGood X goodRho' goodRho'' by (auto simp add: pickQFreshEnv)
  have x''_fresh_rho'': "qFreshEnv xs x'' rho''"
  unfolding x'x''_def using ‹qGood X goodRho' goodRho'' by (auto simp add: pickQFreshEnv)
  obtain u where u_not: "u  {x,x',x''}" and
  u_fresh_X: "qFresh xs u X" and
  u_fresh_rho': "qFreshEnv xs u rho'" and u_fresh_rho'': "qFreshEnv xs u rho''"
  using ‹qGood X goodRho' goodRho''
  using obtain_qFreshEnv[of "{x,x',x''}" "{X}" "{rho',rho''}"] by auto
  (* Preliminary facts and notations: *)
  let ?Xx'x = "X #[[x'  x]]_xs"
    let ?Xx'x_rho' = "?Xx'x #[[rho']]"
      let ?Xx'x_rho'_ux' = "?Xx'x_rho' #[[u  x']]_xs"
    let ?Xx'xux' = "?Xx'x #[[u  x']]_xs"
      let ?Xx'xux'_rho' = "?Xx'xux' #[[rho']]"
  let ?Xux = "X #[[u  x]]_xs"
    let ?Xux_rho' = "?Xux #[[rho']]"
    let ?Xux_rho'' = "?Xux #[[rho'']]"
  let ?Xx''x = "X #[[x''  x]]_xs"
    let ?Xx''xux'' = "?Xx''x #[[u  x'']]_xs"
      let ?Xx''xux''_rho'' = "?Xx''xux'' #[[rho'']]"
    let ?Xx''x_rho'' = "?Xx''x #[[rho'']]"
      let ?Xx''x_rho''_ux'' = "?Xx''x_rho'' #[[u  x'']]_xs"
  (* Good: *)
  have goodXx'x: "qGood ?Xx'x" using ‹qGood X qSwap_preserves_qGood by auto
  hence goodXx'x_rho': "qGood ?Xx'x_rho'" using ‹qGood X goodRho' qPsubst_preserves_qGood by auto
  hence goodXx'x_rho'_ux': "qGood ?Xx'x_rho'_ux'"
  using ‹qGood X qSwap_preserves_qGood by auto
  have goodXx'xux': "qGood ?Xx'xux'" using goodXx'x qSwap_preserves_qGood by auto
  have goodXux: "qGood ?Xux" using ‹qGood X qSwap_preserves_qGood by auto
  have goodXx''x: "qGood ?Xx''x" using ‹qGood X qSwap_preserves_qGood by auto
  hence goodXx''x_rho'': "qGood ?Xx''x_rho''"
  using ‹qGood X goodRho'' qPsubst_preserves_qGood by auto
  (* Fresh: *)
  have "qFresh xs u ?Xx'x" using u_not u_fresh_X
  by(auto simp add: qSwap_preserves_qFresh_distinct)
  hence fresh_Xx'x_rho': "qFresh xs u ?Xx'x_rho'"
  using u_fresh_rho'  goodXx'x goodRho' by(auto simp add: qPsubst_preserves_qFresh)
  have "qFresh xs u ?Xx''x" using u_not u_fresh_X
  by(auto simp add: qSwap_preserves_qFresh_distinct)
  hence fresh_Xx''x_rho'': "qFresh xs u ?Xx''x_rho''"
  using u_fresh_rho''  goodXx''x goodRho'' by(auto simp add: qPsubst_preserves_qFresh)
  (* qSwapped: *)
  have Xux: "(X,?Xux) :qSwapped" by(simp add: qSwap_qSwapped)
  (* Main proof: *)
  have "?Xx'x_rho'_ux' #= ?Xx'xux'_rho'"
  using goodRho' goodXx'x u_fresh_rho' x'_fresh_rho'
  by(auto simp: alpha_qFreshEnv_qSwap_qPsubst_commute alpha_sym)
  moreover
  {have "?Xx'xux' #= ?Xux" using ‹qGood X u_fresh_X x'x''_fresh_X
   using alpha_qFresh_qSwap_compose by fastforce
   hence "?Xx'xux'_rho' #= ?Xux_rho'" using goodXx'xux' goodRho'
   using qPsubst_preserves_alpha1 by auto
  }
  moreover have "?Xux_rho' #= ?Xux_rho''" using Xux Abs.IH by auto
  moreover
  {have "?Xux #= ?Xx''xux''" using ‹qGood X u_fresh_X x'x''_fresh_X
   by(auto simp add: alpha_qFresh_qSwap_compose alpha_sym)
   hence "?Xux_rho'' #= ?Xx''xux''_rho''" using goodXux goodRho''
   using qPsubst_preserves_alpha1 by auto
  }
  moreover have "?Xx''xux''_rho'' #= ?Xx''x_rho''_ux''"
  using goodRho'' goodXx''x u_fresh_rho'' x''_fresh_rho''
  by(auto simp: alpha_qFreshEnv_qSwap_qPsubst_commute)
  ultimately have "?Xx'x_rho'_ux' #= ?Xx''x_rho''_ux''"
  using goodXx'x_rho'_ux' alpha_trans by blast
  hence "qAbs xs ?x' (qPsubst rho' (X #[[?x'  x]]_xs)) $=
         qAbs xs ?x''(qPsubst rho''(X #[[?x'' x]]_xs))"
  unfolding x'x''_rev using goodXx'x_rho' fresh_Xx'x_rho' fresh_Xx''x_rho'' 
  by (auto simp only: alphaAbs_qAbs_iff_ex_qFresh)
  thus ?case by (metis qPsubstAbs.simps)
qed

corollary qPsubst_preserves_alpha2:
"qGood X; qGoodEnv rho'; qGoodEnv rho''; rho' &= rho''
  (X #[[rho']]) #= (X #[[rho'']])"
by(simp add: qPsubstAll_preserves_alphaAll2)

corollary qPsubstAbs_preserves_alphaAbs2:
"qGoodAbs A; qGoodEnv rho'; qGoodEnv rho''; rho' &= rho''
  (A $[[rho']]) $= (A $[[rho'']])"
by(simp add: qPsubstAll_preserves_alphaAll2)

lemma qPsubst_preserves_alpha:
assumes "qGood X  qGood X'" and "qGoodEnv rho" and "qGoodEnv rho'" 
and "X #= X'" and "rho &= rho'"
shows "(X #[[rho]]) #= (X' #[[rho']])"
 by (metis (no_types, lifting) assms alpha_trans qPsubst_preserves_alpha1 
qPsubst_preserves_alpha2 qPsubst_preserves_qGood) 

lemma qPsubstAbs_preserves_alphaAbs:
assumes "qGoodAbs A  qGoodAbs A'" and "qGoodEnv rho" and "qGoodEnv rho'" 
and "A $= A'" and "rho &= rho'"
shows "(A $[[rho]]) $= (A' $[[rho']])"
using assms 
by (meson alphaAbs_trans qPsubstAbs_preserves_alphaAbs1 
    qPsubstAbs_preserves_qGoodAbs qPsubstAll_preserves_alphaAll2)
 
lemma qFresh_qPsubst_commute_qAbs:
assumes good_X: "qGood X" and good_rho: "qGoodEnv rho" and
        x_fresh_rho: "qFreshEnv xs x rho"
shows "((qAbs xs x X) $[[rho]]) $= qAbs xs x (X #[[rho]])"
proof-
  (* Preliminary facts and notations: *)
  let ?x' = "pickQFreshEnv xs {x} {X} {rho}"
  obtain x' where x'_def: "x' = ?x'" and x'_rev: "?x' = x'" by blast
  have x'_not: "x'  x" unfolding x'_def
  using assms pickQFreshEnv[of "{x}" "{X}"] by auto
  have x'_fresh_X: "qFresh xs x' X"  unfolding x'_def
  using assms pickQFreshEnv[of "{x}" "{X}"] by auto
  have x'_fresh_rho: "qFreshEnv xs x' rho"  unfolding x'_def
  using assms pickQFreshEnv[of "{x}" "{X}"] by auto
  obtain u where u_not: "u  {x,x'}" and
  u_fresh_X: "qFresh xs u X" and u_fresh_rho: "qFreshEnv xs u rho"
  using good_X good_rho obtain_qFreshEnv[of "{x,x'}" "{X}" "{rho}"] by auto
  let ?Xx'x = "X #[[x'  x]]_xs"
    let ?Xx'x_rho = "?Xx'x #[[rho]]"
      let ?Xx'x_rho_ux' = "?Xx'x_rho #[[u  x']]_xs"
    let ?Xx'xux' = "?Xx'x #[[u  x']]_xs"
      let ?Xx'xux'_rho = "?Xx'xux' #[[rho]]"
  let ?Xux = "X #[[u  x]]_xs"
    let ?Xux_rho = "?Xux #[[rho]]"
  let ?Xrho = "X #[[rho]]"
    let ?Xrho_ux = "?Xrho #[[u  x]]_xs"
  (* Good: *)
  have good_Xx'x: "qGood ?Xx'x" using good_X qSwap_preserves_qGood by auto
  hence good_Xx'x_rho: "qGood ?Xx'x_rho" using good_rho qPsubst_preserves_qGood by auto
  hence good_Xx'x_rho_ux': "qGood ?Xx'x_rho_ux'" using qSwap_preserves_qGood by auto
  have good_Xx'xux': "qGood ?Xx'xux'" using good_Xx'x qSwap_preserves_qGood by auto
  (* Fresh: *)
  have u_fresh_Xx'x: "qFresh xs u ?Xx'x"
  using u_fresh_X u_not by(auto simp add: qSwap_preserves_qFresh_distinct)
  hence u_fresh_Xx'x_rho: "qFresh xs u ?Xx'x_rho"
  using good_rho good_Xx'x u_fresh_rho by(auto simp add: qPsubst_preserves_qFresh)
  have u_fresh_Xrho: "qFresh xs u ?Xrho"
  using good_rho good_X u_fresh_X u_fresh_rho by(auto simp add: qPsubst_preserves_qFresh)
  (* Main proof: *)  -
  have "?Xx'x_rho_ux' #= ?Xx'xux'_rho"
  using good_Xx'x good_rho u_fresh_rho x'_fresh_rho
  using alpha_qFreshEnv_qSwap_qPsubst_commute alpha_sym by blast
  moreover
  {have "?Xx'xux' #= ?Xux"
   using good_X u_fresh_X x'_fresh_X by (auto simp add: alpha_qFresh_qSwap_compose)
   hence "?Xx'xux'_rho #= ?Xux_rho"
   using good_Xx'xux' good_rho qPsubst_preserves_alpha1 by auto
  }  
  moreover have "?Xux_rho #= ?Xrho_ux"
  using good_X good_rho u_fresh_rho x_fresh_rho
  using alpha_qFreshEnv_qSwap_qPsubst_commute by blast
  ultimately have "?Xx'x_rho_ux' #= ?Xrho_ux"
  using good_Xx'x_rho_ux' alpha_trans by blast
  thus ?thesis apply (simp add: Let_def del: alpha.simps alphaAbs.simps) 
  unfolding x'_rev using good_Xx'x_rho
  using u_fresh_Xx'x_rho u_fresh_Xrho by (auto simp only: alphaAbs_qAbs_iff_ex_qFresh) 
qed

end  (* context FixVars *)

end

Theory Pick

theory Pick imports Main
begin

definition "pick X  SOME x. x  X"

lemma pick[simp]: "x  X  pick X  X"
unfolding pick_def by (metis someI_ex)

lemma pick_NE[simp]: "X  {}  pick X  X" by auto


end

Theory Equiv_Relation2

section ‹Some preliminaries on equivalence relations and quotients›

theory Equiv_Relation2 imports Preliminaries Pick
begin


text‹Unary predicates vs. sets:›

definition "S2P A  λ x. x  A"

lemma S2P_app[simp]: "S2P r x  x  r"
unfolding S2P_def by auto

lemma S2P_Collect[simp]: "S2P (Collect φ) = φ"
apply(rule ext)+ by simp

lemma Collect_S2P[simp]: "Collect (S2P r) = r"
by (metis Collect_mem_eq S2P_Collect)


text‹Binary predicates vs. relatipons:›
definition "P2R φ  {(x,y). φ x y}"
definition "R2P r  λ x y. (x,y)  r"

lemma in_P2R[simp]: "xy  P2R φ  φ (fst xy) (snd xy)"
unfolding P2R_def by auto

lemma in_P2R_pair[simp]: "(x,y)  P2R φ  φ x y"
by simp

lemma R2P_app[simp]: "R2P r x y  (x,y)  r"
unfolding R2P_def by auto

lemma R2P_P2R[simp]: "R2P (P2R φ) = φ"
apply(rule ext)+ by simp

lemma P2R_R2P[simp]: "P2R (R2P r) = r"
using Collect_mem_eq P2R_def R2P_P2R  case_prod_curry by metis

definition "reflP P φ  ( x y. φ x y  φ y x  P x)  ( x. P x  φ x x)"
definition "symP φ   x y. φ x y  φ y x"
definition transP where "transP φ   x y z. φ x y  φ y z  φ x z"
definition "equivP A φ  reflP A φ  symP φ  transP φ"

lemma refl_on_P2R[simp]: "refl_on (Collect P) (P2R φ)  reflP P φ"
unfolding reflP_def refl_on_def by force

lemma reflP_R2P[simp]: "reflP (S2P A) (R2P r)  refl_on A r"
unfolding reflP_def refl_on_def by auto

lemma sym_P2R[simp]: "sym (P2R φ)  symP φ"
unfolding symP_def sym_def by auto

lemma symP_R2P[simp]: "symP (R2P r)  sym r"
unfolding symP_def sym_def by auto

lemma trans_P2R[simp]: "trans (P2R φ)  transP φ"
unfolding transP_def trans_def by auto

lemma transP_R2P[simp]: "transP (R2P r)  trans r"
unfolding transP_def trans_def by auto

lemma equiv_P2R[simp]: "equiv (Collect P) (P2R φ)  equivP P φ"
unfolding equivP_def equiv_def by auto

lemma equivP_R2P[simp]: "equivP (S2P A) (R2P r)  equiv A r"
unfolding equivP_def equiv_def by auto

lemma in_P2R_Im_singl[simp]: "y  P2R φ `` {x}  φ x y" by simp

definition proj :: "('a  'a  bool)  'a  'a set" where
"proj φ x  {y. φ x y}"

lemma proj_P2R: "proj φ x = P2R φ `` {x}" unfolding proj_def by auto

lemma proj_P2R_raw: "proj φ = (λ x. P2R φ `` {x})"
apply(rule ext) unfolding proj_P2R ..

definition univ :: "('a  'b)  ('a set  'b)"
where "univ f X == f (SOME x. x  X)"

definition quotientP ::
"('a  bool)  ('a  'a  bool)  ('a set  bool)"  (infixl "'/'/'/" 90)
where "P /// φ  S2P ((Collect P) // (P2R φ))"

lemma proj_preserves:
"P x  (P /// φ) (proj φ x)"
unfolding proj_P2R quotientP_def
by (metis S2P_def mem_Collect_eq quotientI)

lemma proj_in_iff:
assumes "equivP P φ"
shows "(P///φ) (proj φ x)   P x"
using assms unfolding quotientP_def proj_def 
by (metis (mono_tags) Collect_mem_eq Equiv_Relation2.proj_def 
  Equiv_Relation2.proj_preserves S2P_Collect empty_Collect_eq equivP_def 
  equiv_P2R in_quotient_imp_non_empty quotientP_def reflP_def)

lemma proj_iff[simp]:
"equivP P φ; P x; P y  proj φ x = proj φ y  φ x y"
unfolding proj_P2R
by (metis (full_types) equiv_P2R equiv_class_eq_iff equiv_class_self
          in_P2R_pair mem_Collect_eq proj_P2R proj_def)

lemma in_proj[simp]: "equivP P φ; P x  x  proj φ x"
unfolding proj_P2R equiv_def refl_on_def equiv_P2R[symmetric]
by auto

lemma proj_image[simp]: "(proj φ) ` (Collect P) = Collect (P///φ)"
unfolding proj_P2R_raw quotientP_def quotient_def by auto

lemma in_quotientP_imp_non_empty:
assumes "equivP P φ" and "(P///φ) X"
shows "X  {}" 
by (metis R2P_P2R S2P_Collect S2P_def assms equivP_R2P 
in_quotient_imp_non_empty quotientP_def)

lemma in_quotientP_imp_in_rel:
"equivP P φ; (P///φ) X; x  X; y  X  φ x y"
unfolding equiv_P2R[symmetric] quotientP_def quotient_eq_iff
by (metis S2P_def in_P2R_pair quotient_eq_iff)

lemma in_quotientP_imp_closed:
"equivP P φ; (P///φ) X; x  X; φ x y  y  X"
using S2P_Collect S2P_def equivP_def proj_P2R_raw proj_def
        quotientE quotientP_def transP_def 
by metis 

lemma in_quotientP_imp_subset:
assumes "equivP P φ" and "(P///φ) X"
shows "X  Collect P"
by (metis (mono_tags, lifting) CollectI assms equivP_def in_quotientP_imp_in_rel reflP_def subsetI)

lemma equivP_pick_in:
assumes  "equivP P φ " and "(P///φ) X"
shows "pick X  X"
by (metis assms in_quotientP_imp_non_empty pick_NE)

lemma equivP_pick_preserves:
assumes  "equivP P φ " and "(P///φ) X"
shows "P (pick X)"
by (metis assms equivP_pick_in in_quotientP_imp_subset mem_Collect_eq set_rev_mp)

lemma proj_pick:
assumes φ: "equivP P φ" and X: "(P///φ) X"
shows "proj φ (pick X) = X"
by (smt proj_def Equiv_Relation2.proj_iff Equiv_Relation2.proj_image X 
   φ equivP_pick_in equivP_pick_preserves image_iff mem_Collect_eq)
 
lemma pick_proj:
assumes "equivP P φ" and "P x"
shows "φ (pick (proj φ x)) x"
by (metis assms equivP_def in_proj mem_Collect_eq pick proj_def symP_def)

lemma equivP_pick_iff[simp]:
assumes φ: "equivP P φ" and X: "(P///φ) X" and Y: "(P///φ) Y"
shows "φ (pick X) (pick Y)  X = Y"
by (metis Equiv_Relation2.proj_iff X Y φ equivP_pick_preserves proj_pick)

lemma equivP_pick_inj_on:
assumes "equivP P φ"
shows "inj_on pick (Collect (P///φ))"
using assms unfolding inj_on_def
by (metis assms equivP_pick_iff mem_Collect_eq)

definition congruentP where
"congruentP φ f   x y. φ x y  f x = f y"

abbreviation RESPECTS_P (infixr "respectsP" 80) where
"f respectsP r == congruentP r f"

lemma congruent_P2R: "congruent (P2R φ) f = congruentP φ f"
unfolding congruent_def congruentP_def by auto
 
lemma univ_commute[simp]:
assumes "equivP P φ" and "f respectsP φ" and "P x"
shows "(univ f) (proj φ x) = f x"
unfolding congruent_P2R[symmetric]
by (metis (full_types) assms pick_def congruentP_def pick_proj univ_def)

lemma univ_unique:
assumes "equivP P φ" and "f respectsP φ" and " x. P x  G (proj φ x) = f x"
shows " X. (P///φ) X  G X = univ f X"
by (metis assms equivP_pick_preserves proj_pick univ_commute)

lemma univ_preserves:
assumes "equivP P φ " and "f respectsP φ" and " x. P x  f x  B"
shows " X. (P///φ) X  univ f X  B"
by (metis Equiv_Relation2.univ_commute assms  
          equivP_pick_preserves proj_pick) 




end

Theory Transition_QuasiTerms_Terms

section ‹Transition from Quasi-Terms to Terms›

theory Transition_QuasiTerms_Terms
imports QuasiTerms_Environments_Substitution Equiv_Relation2
begin

text‹This section transits from quasi-terms to terms: defines terms as alpha-equivalence
classes of quasi-terms
(and also abstractions as alpha-equivalence classes of  quasi-abstractions),
then defines operators on terms corresponding to those on quasi-terms:
variable injection, binding operation, freshness, swapping, parallel substitution, etc.
Properties previously shown invariant
under alpha-equivalence, including induction principles, are lifted from quasi-terms.
Moreover, a new powerful induction principle, allowing freshness assumptions,
is proved for terms.

As a matter of notation:
Starting from this section, we change the notations for quasi-item meta-variables, prefixing
their names with a "q" -- e.g., qX, qA, qinp, qenv, etc. The old names are now assigned
to the ``real" items: terms, abstractions, inputs, environments.›

subsection ‹Preparation: Integrating quasi-inputs as first-class citizens›

context FixVars
begin

text‹From now on it will be convenient to
   also define fresh, swap, good and alpha-equivalence for quasi-inpus.›

definition qSwapInp where
"qSwapInp xs x y qinp == lift (qSwap xs x y) qinp"

definition qSwapBinp where
"qSwapBinp xs x y qbinp == lift (qSwapAbs xs x y) qbinp"

abbreviation qSwapInp_abbrev ("_ %[[_  _]]'__" 200) where
"(qinp %[[z1  z2]]_zs) == qSwapInp zs z1 z2 qinp"

abbreviation qSwapBinp_abbrev ("_ %%[[_  _]]'__" 200) where
"(qbinp %%[[z1  z2]]_zs) == qSwapBinp zs z1 z2 qbinp"

lemma qSwap_qSwapInp:
"((qOp delta qinp qbinp) #[[x  y]]_xs) =
 qOp delta (qinp %[[x  y]]_xs) (qbinp %%[[x  y]]_xs)"
unfolding qSwapInp_def qSwapBinp_def by simp

(* For the qOp case, qSwap shall henceforth simplify to qSwapInp:  *)

declare qSwap.simps(2) [simp del]
declare qSwap_qSwapInp[simp]

(* and qSwap_simps and qSwapAll_simps, rather than qSwap.simps and qSwapAll.simps,
   shall refer to the simplification rules for qSwap *)

lemmas qSwapAll_simps = qSwap.simps(1) qSwap_qSwapInp

definition qPsubstInp where
"qPsubstInp qrho qinp == lift (qPsubst qrho) qinp"

definition qPsubstBinp where
"qPsubstBinp qrho qbinp == lift (qPsubstAbs qrho) qbinp"

abbreviation qPsubstInp_abbrev ("_ %[[_]]" 200)
where "(qinp %[[qrho]]) == qPsubstInp qrho qinp"

abbreviation qPsubstBinp_abbrev ("_ %%[[_]]" 200)
where "(qbinp %%[[qrho]]) == qPsubstBinp qrho qbinp"

lemma qPsubst_qPsubstInp:
"((qOp delta qinp qbinp) #[[rho]]) = qOp delta (qinp %[[rho]]) (qbinp %%[[rho]])"
unfolding qPsubstInp_def qPsubstBinp_def by simp

(* For the qOp case, qPsubst shall henceforth simplify to qPsubstInp:  *)

declare qPsubst.simps(2) [simp del]
declare qPsubst_qPsubstInp[simp]

(* and qPsubst_simps and qPsubstAll_simps, rather than qPsubst.simps and qPsubstAll.simps,
   shall refer to the simplification rules for qPsubst *)

lemmas qPsubstAll_simps = qPsubst.simps(1) qPsubst_qPsubstInp

definition qSkelInp
where "qSkelInp qinp = lift qSkel qinp"

definition qSkelBinp
where "qSkelBinp qbinp = lift qSkelAbs qbinp"

lemma qSkel_qSkelInp:
"qSkel (qOp delta qinp qbinp) =
 Branch (qSkelInp qinp) (qSkelBinp qbinp)"
unfolding qSkelInp_def qSkelBinp_def by simp

(* For the qOp case, qSkel shall henceforth simplify to qSkelInp:  *)

declare qSkel.simps(2) [simp del]
declare qSkel_qSkelInp[simp]

(* and qSkel_simps and qSkelAll_simps, rather than qSkel.simps and qSkelAll.simps,
   shall refer to the simplification rules for qSkel *)

lemmas qSkelAll_simps = qSkel.simps(1) qSkel_qSkelInp

definition qFreshInp ::
"'varSort  'var  ('index,('index,'bindex,'varSort,'var,'opSym)qTerm)input  bool"
where
"qFreshInp xs x qinp == liftAll (qFresh xs x) qinp"

definition qFreshBinp ::
"'varSort  'var  ('bindex,('index,'bindex,'varSort,'var,'opSym)qAbs)input  bool"
where
"qFreshBinp xs x qbinp == liftAll (qFreshAbs xs x) qbinp"

lemma qFresh_qFreshInp:
"qFresh xs x (qOp delta qinp qbinp) =
 (qFreshInp xs x qinp  qFreshBinp xs x qbinp)"
unfolding qFreshInp_def qFreshBinp_def by simp

(* For the qOp case, qFresh shall henceforth simplify to qFreshInp:  *)

declare qFresh.simps(2) [simp del]
declare qFresh_qFreshInp[simp]

(* and qFresh_simps and qFreshAll_simps, rather than qFresh.simps and qFreshAll.simps,
   shall refer to the simplification rules for qFresh *)

lemmas qFreshAll_simps = qFresh.simps(1) qFresh_qFreshInp

definition qGoodInp where
"qGoodInp qinp ==
 liftAll qGood qinp 
 |{i. qinp i  None}| <o |UNIV :: 'var set|"

definition qGoodBinp where
"qGoodBinp qbinp ==
 liftAll qGoodAbs qbinp 
 |{i. qbinp i  None}| <o |UNIV :: 'var set|"

lemma qGood_qGoodInp:
"qGood (qOp delta qinp qbinp) = (qGoodInp qinp  qGoodBinp qbinp)"
unfolding qGoodInp_def qGoodBinp_def by auto

(* For the qOp case, qGood shall henceforth simplify to qGoodInp:  *)

declare qGood.simps(2) [simp del]
declare qGood_qGoodInp [simp]

(* and qGood_simps (and qGoodAll_simps), rather than qGood.simps,
   shall refer to the simplification rules for qGood *)

lemmas qGoodAll_simps = qGood.simps(1) qGood_qGoodInp

definition alphaInp where
"alphaInp ==
 {(qinp,qinp'). sameDom qinp qinp'  liftAll2 (λqX qX'. qX #= qX') qinp qinp'}"

definition alphaBinp where
"alphaBinp ==
 {(qbinp,qbinp'). sameDom qbinp qbinp'  liftAll2 (λqA qA'. qA $= qA') qbinp qbinp'}"

abbreviation alphaInp_abbrev (infix "%=" 50) where
"qinp %= qinp' == (qinp,qinp')  alphaInp"

abbreviation alphaBinp_abbrev (infix "%%=" 50) where
"qbinp %%= qbinp' == (qbinp,qbinp')  alphaBinp"

lemma alpha_alphaInp:
"(qOp delta qinp qbinp #= qOp delta' qinp' qbinp') =
 (delta = delta'  qinp %= qinp'  qbinp %%= qbinp')"
unfolding alphaInp_def alphaBinp_def by auto

(* For the qOp case, alpha shall henceforth simplify to alphaInp:  *)
declare alpha.simps(2) [simp del]
declare alpha_alphaInp[simp]

(* and alpha_Simps and alphaAll_Simps, rather than alpha_simps and alphaAll_simps,
   shall refer to the simplification rules for alpha *)

lemmas alphaAll_Simps =
alpha.simps(1) alpha_alphaInp
alphaAbs.simps

lemma alphaInp_refl:
"qGoodInp qinp  qinp %= qinp"
using alpha_refl
unfolding alphaInp_def qGoodInp_def liftAll_def liftAll2_def sameDom_def
by fastforce

lemma alphaBinp_refl:
"qGoodBinp qbinp  qbinp %%= qbinp"
using alphaAbs_refl
unfolding alphaBinp_def qGoodBinp_def liftAll_def liftAll2_def sameDom_def
by fastforce

lemma alphaInp_sym:
fixes qinp qinp' :: "('index,('index,'bindex,'varSort,'var,'opSym)qTerm)input"
shows "qinp %= qinp'  qinp' %= qinp"
using alpha_sym unfolding alphaInp_def sameDom_def liftAll2_def by blast

lemma alphaBinp_sym:
fixes qbinp qbinp' :: "('bindex,('index,'bindex,'varSort,'var,'opSym)qAbs)input"
shows "qbinp %%= qbinp'  qbinp' %%= qbinp"
using alphaAbs_sym unfolding alphaBinp_def sameDom_def liftAll2_def by blast

lemma alphaInp_trans:
assumes good: "qGoodInp qinp" and
        alpha1: "qinp %= qinp'" and alpha2: "qinp' %= qinp''"
shows "qinp %= qinp''"
proof-
  {fix i qX qX''  assume qinp: "qinp i = Some qX" and qinp'': "qinp'' i = Some qX''"
  then obtain qX' where qinp': "qinp' i = Some qX'"
  using alpha1 unfolding alphaInp_def sameDom_def liftAll2_def by(cases "qinp' i", force)
  hence "qX #= qX'"
  using alpha1 qinp unfolding alphaInp_def sameDom_def liftAll2_def by auto
  moreover have "qX' #= qX''" using alpha2 qinp' qinp''
  unfolding alphaInp_def sameDom_def liftAll2_def by auto
  moreover have "qGood qX" using good qinp unfolding qGoodInp_def liftAll_def by auto
  ultimately have "qX #= qX''" using alpha_trans by blast
  }
  thus ?thesis using assms unfolding alphaInp_def sameDom_def liftAll2_def by auto
qed

lemma alphaBinp_trans:
assumes good: "qGoodBinp qbinp" and
        alpha1: "qbinp %%= qbinp'" and alpha2: "qbinp' %%= qbinp''"
shows "qbinp %%= qbinp''"
proof-
  {fix i qA qA''  assume qbinp: "qbinp i = Some qA" and qbinp'': "qbinp'' i = Some qA''"
  then obtain qA' where qbinp': "qbinp' i = Some qA'"
  using alpha1 unfolding alphaBinp_def sameDom_def liftAll2_def by(cases "qbinp' i", force)
  hence "qA $= qA'"
  using alpha1 qbinp unfolding alphaBinp_def sameDom_def liftAll2_def by auto
  moreover have "qA' $= qA''" using alpha2 qbinp' qbinp''
  unfolding alphaBinp_def sameDom_def liftAll2_def by auto
  moreover have "qGoodAbs qA" using good qbinp unfolding qGoodBinp_def liftAll_def by auto
  ultimately have "qA $= qA''" using alphaAbs_trans by blast
  }
  thus ?thesis using assms unfolding alphaBinp_def sameDom_def liftAll2_def by auto
qed

lemma qSwapInp_preserves_qGoodInp:
assumes "qGoodInp qinp"
shows "qGoodInp (qinp %[[x1  x2]]_xs)"
proof-
  {let ?qinp' = "lift (qSwap xs x1 x2) qinp"
  fix xsa  let ?Left = "{i. ?qinp' i  None}"
  have "?Left = {i. qinp i  None}" by(auto simp add: lift_None)
  hence "|?Left| <o |UNIV :: 'var set|" using assms unfolding qGoodInp_def by auto
  }
  thus ?thesis using assms 
  unfolding qGoodInp_def qSwapInp_def liftAll_lift_comp qGoodInp_def
  unfolding comp_def liftAll_def
  by (auto simp add: qSwap_preserves_qGood simp del: not_None_eq)
qed

lemma qSwapBinp_preserves_qGoodBinp:
assumes "qGoodBinp qbinp"
shows "qGoodBinp (qbinp %%[[x1  x2]]_xs)"
proof-
  {let ?qbinp' = "lift (qSwapAbs xs x1 x2) qbinp"
  fix xsa  let ?Left = "{i. ?qbinp' i  None}"
  have "?Left = {i. qbinp i  None}" by(auto simp add: lift_None)
  hence "|?Left| <o |UNIV :: 'var set|" using assms unfolding qGoodBinp_def by auto
  }
  thus ?thesis using assms 
  unfolding qGoodBinp_def qSwapBinp_def liftAll_lift_comp 
  unfolding qGoodBinp_def unfolding comp_def liftAll_def
  by (auto simp add: qSwapAbs_preserves_qGoodAbs simp del: not_None_eq)
qed

lemma qSwapInp_preserves_alphaInp:
assumes "qGoodInp qinp  qGoodInp qinp'" and "qinp %= qinp'"
shows "(qinp %[[x1  x2]]_xs) %= (qinp' %[[x1  x2]]_xs)"
using assms unfolding alphaInp_def qSwapInp_def sameDom_def liftAll2_def
by (simp add: lift_None)  
   (smt liftAll_def lift_def option.case_eq_if option.exhaust_sel 
      option.sel qGoodInp_def qSwap_preserves_alpha)

lemma qSwapBinp_preserves_alphaBinp:
assumes "qGoodBinp qbinp  qGoodBinp qbinp'" and "qbinp %%= qbinp'"
shows "(qbinp %%[[x1  x2]]_xs) %%= (qbinp' %%[[x1  x2]]_xs)"
using assms unfolding alphaBinp_def qSwapBinp_def sameDom_def liftAll2_def
by (simp add: lift_None)
   (smt liftAll_def lift_def option.case_eq_if option.exhaust_sel option.sel 
     qGoodBinp_def qSwapAbs_preserves_alphaAbs) 

lemma qPsubstInp_preserves_qGoodInp:
assumes "qGoodInp qinp" and "qGoodEnv qrho"
shows "qGoodInp (qinp %[[qrho]])"
using assms unfolding qGoodInp_def qPsubstInp_def liftAll_def
by simp (smt Collect_cong lift_def option.case_eq_if 
   option.exhaust_sel option.sel qPsubst_preserves_qGood) 

lemma qPsubstBinp_preserves_qGoodBinp:
assumes "qGoodBinp qbinp" and "qGoodEnv qrho"
shows "qGoodBinp (qbinp %%[[qrho]])"
using assms unfolding qGoodBinp_def qPsubstBinp_def liftAll_def
by simp (smt Collect_cong lift_def option.case_eq_if 
   option.exhaust_sel option.sel qPsubstAbs_preserves_qGoodAbs)  

lemma qPsubstInp_preserves_alphaInp:
assumes "qGoodInp qinp  qGoodInp qinp'" and "qGoodEnv qrho" and "qinp %= qinp'"
shows "(qinp %[[qrho]]) %= (qinp' %[[qrho]])"
using assms unfolding alphaInp_def qPsubstInp_def sameDom_def liftAll2_def
by (simp add: lift_None)
   (smt liftAll_def lift_def option.case_eq_if option.exhaust_sel 
       option.sel qGoodInp_def qPsubst_preserves_alpha1)

lemma qPsubstBinp_preserves_alphaBinp:
assumes "qGoodBinp qbinp  qGoodBinp qbinp'" and "qGoodEnv qrho" and "qbinp %%= qbinp'"
shows "(qbinp %%[[qrho]]) %%= (qbinp' %%[[qrho]])"
using assms unfolding alphaBinp_def qPsubstBinp_def sameDom_def liftAll2_def
by (simp add: lift_None)
   (smt liftAll_def lift_def option.case_eq_if option.exhaust_sel 
       option.sel qGoodBinp_def qPsubstAbs_preserves_alphaAbs1) 

lemma qFreshInp_preserves_alphaInp_aux:
assumes good: "qGoodInp qinp  qGoodInp qinp'" and alpha: "qinp %= qinp'"
and fresh: "qFreshInp xs x qinp"
shows "qFreshInp xs x qinp'"
using assms unfolding qFreshInp_def liftAll_def proof clarify
  fix i qX' assume qinp': "qinp' i = Some qX'"
  then obtain qX where qinp: "qinp i = Some qX"
  using alpha unfolding alphaInp_def sameDom_def liftAll2_def by (cases "qinp i", auto)
  hence "qGood qX  qGood qX'"
  using qinp' good unfolding qGoodInp_def liftAll_def by auto
  moreover have "qX #= qX'"
  using qinp qinp' alpha unfolding alphaInp_def sameDom_def liftAll2_def by auto
  moreover have "qFresh xs x qX"
  using fresh qinp unfolding qFreshInp_def liftAll_def by simp
  ultimately show "qFresh xs x qX'"
  using qFresh_preserves_alpha by auto
qed

lemma qFreshBinp_preserves_alphaBinp_aux:
assumes good: "qGoodBinp qbinp  qGoodBinp qbinp'" and alpha: "qbinp %%= qbinp'"
and fresh: "qFreshBinp xs x qbinp"
shows "qFreshBinp xs x qbinp'"
using assms unfolding qFreshBinp_def liftAll_def proof clarify
  fix i qA' assume qbinp': "qbinp' i = Some qA'"
  then obtain qA where qbinp: "qbinp i = Some qA"
  using alpha unfolding alphaBinp_def sameDom_def liftAll2_def by (cases "qbinp i", auto)
  hence "qGoodAbs qA  qGoodAbs qA'"
  using qbinp' good unfolding qGoodBinp_def liftAll_def by auto
  moreover have "qA $= qA'"
  using qbinp qbinp' alpha unfolding alphaBinp_def sameDom_def liftAll2_def by auto
  moreover have "qFreshAbs xs x qA"
  using fresh qbinp unfolding qFreshBinp_def liftAll_def by simp
  ultimately show "qFreshAbs xs x qA'"
  using qFreshAbs_preserves_alphaAbs by auto
qed

lemma qFreshInp_preserves_alphaInp:
assumes "qGoodInp qinp  qGoodInp qinp'" and "qinp %= qinp'"
shows "qFreshInp xs x qinp  qFreshInp xs x qinp'"
using alphaInp_sym assms qFreshInp_preserves_alphaInp_aux by blast
 
lemma qFreshBinp_preserves_alphaBinp:
assumes "qGoodBinp qbinp  qGoodBinp qbinp'" and "qbinp %%= qbinp'"
shows "qFreshBinp xs x qbinp  qFreshBinp xs x qbinp'"
using alphaBinp_sym assms qFreshBinp_preserves_alphaBinp_aux by blast
 

(****************************************************)
lemmas qItem_simps =
qSkelAll_simps qFreshAll_simps qSwapAll_simps qPsubstAll_simps qGoodAll_simps alphaAll_Simps
qSwap_qAFresh_otherSimps qAFresh.simps qGoodItem.simps
(****************************************************)

end (* context FixVars *)

subsection ‹Definitions of terms and their operators›

type_synonym ('index,'bindex,'varSort,'var,'opSym)"term" =
      "('index,'bindex,'varSort,'var,'opSym)qTerm set"

type_synonym ('index,'bindex,'varSort,'var,'opSym)abs =
      "('index,'bindex,'varSort,'var,'opSym)qAbs set"

type_synonym ('index,'bindex,'varSort,'var,'opSym)env =
      "'varSort  'var  ('index,'bindex,'varSort,'var,'opSym)term option"

text‹A ``parameter" will be something for which
freshness makes sense.  Here is the most typical case of a parameter in proofs, putting
together (as lists) finite collections of variables, terms, abstractions and environments:›

datatype ('index,'bindex,'varSort,'var,'opSym)param =
  Par "'var list"
      "('index,'bindex,'varSort,'var,'opSym)term list"
      "('index,'bindex,'varSort,'var,'opSym)abs list"
      "('index,'bindex,'varSort,'var,'opSym)env list"

fun varsOf where
"varsOf (Par xL _ _ _) = set xL"

fun termsOf where
"termsOf (Par _ XL _ _) = set XL"

fun absOf where
"absOf (Par _ _ AL _) = set AL"

fun envsOf where
"envsOf (Par _ _ _ rhoL) = set rhoL"

context FixVars  (* scope all throughout the file *)
begin

(* Recall the abbreviation "Restr r qA" for "r Int (qA <*> qA)"  *)
definition "alphaGood  λ qX qY. qGood qX  qGood qY  qX #= qY"
definition "alphaAbsGood  λ qA qB. qGoodAbs qA  qGoodAbs qB  qA $= qB"

definition "good  qGood /// alphaGood"
definition "goodAbs  qGoodAbs /// alphaAbsGood"

definition goodInp where
"goodInp inp ==
 liftAll good inp 
 |{i. inp i  None}| <o |UNIV :: 'var set|"

definition goodBinp where
"goodBinp binp ==
 liftAll goodAbs binp 
 |{i. binp i  None}| <o |UNIV :: 'var set|"

definition goodEnv where
"goodEnv rho ==
 ( ys. liftAll good (rho ys)) 
 ( ys. |{y. rho ys y  None}| <o |UNIV :: 'var set| )"

definition asTerm where
"asTerm qX  proj alphaGood qX"

definition asAbs where
"asAbs qA  proj alphaAbsGood qA"

definition pickInp where
"pickInp inp  lift pick inp"

definition pickBinp where
"pickBinp binp  lift pick binp"

(* Note: pickInp and pickBinp are the same (polymorphically), but
  I keep distinct notations for uniformity with the rest of the notations. *)

definition asInp where
"asInp qinp  lift asTerm qinp"

definition asBinp where
"asBinp qbinp  lift asAbs qbinp"

definition pickE where
"pickE rho  λ xs. lift pick (rho xs)" 

definition asEnv where
"asEnv qrho  λ xs. lift asTerm (qrho xs)"

definition Var where
"Var xs x  asTerm(qVar xs x)"

definition Op where
"Op delta inp binp  asTerm (qOp delta (pickInp inp) (pickBinp binp))"

definition Abs where
"Abs xs x X  asAbs (qAbs xs x (pick X))"

definition skel where
"skel X  qSkel (pick X)"

definition skelAbs where
"skelAbs A  qSkelAbs (pick A)"

definition skelInp where
"skelInp inp = qSkelInp (pickInp inp)"

definition skelBinp where
"skelBinp binp = qSkelBinp (pickBinp binp)"

lemma skelInp_def2:
assumes "goodInp inp"
shows "skelInp inp = lift skel inp"
unfolding skelInp_def
unfolding qSkelInp_def pickInp_def skel_def[abs_def]
unfolding lift_comp comp_def by simp

lemma skelBinp_def2:
assumes "goodBinp binp"
shows "skelBinp binp = lift skelAbs binp"
unfolding skelBinp_def
unfolding qSkelBinp_def pickBinp_def skelAbs_def[abs_def]
unfolding lift_comp comp_def by simp

definition swap where
"swap xs x y X = asTerm (qSwap xs x y (pick X))"

abbreviation swap_abbrev ("_ #[_  _]'__" 200) where
"(X #[z1  z2]_zs)  swap zs z1 z2 X"

definition swapAbs where
"swapAbs xs x y A = asAbs (qSwapAbs xs x y (pick A))"

abbreviation swapAbs_abbrev ("_ $[_  _]'__" 200) where
"(A $[z1  z2]_zs)  swapAbs zs z1 z2 A"

definition swapInp where
"swapInp xs x y inp  lift (swap xs x y) inp"

definition swapBinp where
"swapBinp xs x y binp  lift (swapAbs xs x y) binp"

abbreviation swapInp_abbrev ("_ %[_  _]'__" 200) where
"(inp %[z1  z2]_zs)  swapInp zs z1 z2 inp"

abbreviation swapBinp_abbrev ("_ %%[_  _]'__" 200) where
"(binp %%[z1  z2]_zs)  swapBinp zs z1 z2 binp"

definition swapEnvDom where
"swapEnvDom xs x y rho  λzs z. rho zs (z @zs[x  y]_xs)"

definition swapEnvIm where
"swapEnvIm xs x y rho  λzs. lift (swap xs x y) (rho zs)"

definition swapEnv where
"swapEnv xs x y  swapEnvIm xs x y o swapEnvDom xs x y"

abbreviation swapEnv_abbrev ("_ &[_  _]'__" 200) where
"(rho &[z1  z2]_zs)  swapEnv zs z1 z2 rho"

lemmas swapEnv_defs = swapEnv_def comp_def swapEnvDom_def swapEnvIm_def

inductive_set swapped where
Refl: "(X,X)  swapped"
|
Trans: "(X,Y)  swapped; (Y,Z)  swapped  (X,Z)  swapped"
|
Swap: "(X,Y)  swapped  (X, Y #[x  y]_zs)  swapped"

lemmas swapped_Clauses = swapped.Refl swapped.Trans swapped.Swap

definition fresh where
"fresh xs x X  qFresh xs x (pick X)"

definition freshAbs where
"freshAbs xs x A  qFreshAbs xs x (pick A)"

definition freshInp where
"freshInp xs x inp  liftAll (fresh xs x) inp"

definition freshBinp where
"freshBinp xs x binp  liftAll (freshAbs xs x) binp"

definition freshEnv where
"freshEnv xs x rho ==
rho xs x = None  ( ys. liftAll (fresh xs x) (rho ys))"

definition psubst where
"psubst rho X  asTerm(qPsubst (pickE rho) (pick X))"

abbreviation psubst_abbrev ("_ #[_]") where
"(X #[rho])  psubst rho X"

definition psubstAbs where
"psubstAbs rho A  asAbs(qPsubstAbs (pickE rho) (pick A))"

abbreviation psubstAbs_abbrev  ("_ $[_]") where
"A $[rho]  psubstAbs rho A"

definition psubstInp where
"psubstInp rho inp  lift (psubst rho) inp"

definition psubstBinp where
"psubstBinp rho binp  lift (psubstAbs rho) binp"

abbreviation psubstInp_abbrev  ("_ %[_]") where
"inp %[rho]  psubstInp rho inp"

abbreviation psubstBinp_abbrev  ("_ %%[_]") where
"binp %%[rho]  psubstBinp rho binp"

definition psubstEnv where
"psubstEnv rho rho' 
 λ xs x. case rho' xs x of None  rho xs x
                          |Some X  Some (X #[rho])"

abbreviation psubstEnv_abbrev ("_ &[_]") where
"rho &[rho']  psubstEnv rho' rho"

definition idEnv where
"idEnv  λxs. Map.empty"

definition updEnv ::
"('index,'bindex,'varSort,'var,'opSym)env 
 'var  ('index,'bindex,'varSort,'var,'opSym)term  'varSort 
 ('index,'bindex,'varSort,'var,'opSym)env"
("_ [_  _]'__" 200) where
"(rho [x  X]_xs)  λ ys y. (if ys = xs  y = x then Some X else rho ys y)"

text‹(Unary) substitution:›

definition subst where
"subst xs X x  psubst (idEnv [x  X]_xs)"

abbreviation subst_abbrev ("_ #[_ '/ _]'__" 200) where
"(Y #[X / x]_xs)  subst xs X x Y"

definition substAbs where
"substAbs xs X x  psubstAbs (idEnv [x  X]_xs)"

abbreviation substAbs_abbrev ("_ $[_ '/ _]'__" 200) where
"(A $[X / x]_xs)  substAbs xs X x A"

definition substInp where
"substInp xs X x  psubstInp (idEnv [x  X]_xs)"

definition substBinp where
"substBinp xs X x  psubstBinp (idEnv [x  X]_xs)"

abbreviation substInp_abbrev ("_ %[_ '/ _]'__" 200) where
"(inp %[X / x]_xs)  substInp xs X x inp"

abbreviation substBinp_abbrev ("_ %%[_ '/ _]'__" 200) where
"(binp %%[X / x]_xs)  substBinp xs X x binp"

theorem substInp_def2:
"substInp ys Y y = lift (subst ys Y y)"
unfolding substInp_def[abs_def] subst_def psubstInp_def[abs_def] by simp

theorem substBinp_def2:
"substBinp ys Y y = lift (substAbs ys Y y)"
unfolding substBinp_def[abs_def] substAbs_def psubstBinp_def[abs_def] by simp

definition substEnv where
"substEnv xs X x  psubstEnv (idEnv [x  X]_xs)"

abbreviation substEnv_abbrev ("_ &[_ '/ _]'__" 200) where
"(Y &[X / x]_xs)  substEnv xs X x Y"

theorem substEnv_def2:
"(rho &[Y / y]_ys) =
 (λxs x. case rho xs x of
           None  if (xs = ys  x = y) then Some Y else None
          |Some X  Some (X #[Y / y]_ys))"
unfolding substEnv_def psubstEnv_def subst_def idEnv_def updEnv_def
apply(rule ext)+ by(case_tac "rho xs x", simp_all)

text‹Variable-for-variable substitution:›

definition vsubst where
"vsubst ys y1 y2  subst ys (Var ys y1) y2"

abbreviation vsubst_abbrev ("_ #[_ '/'/ _]'__" 200) where
"(X #[y1 // y2]_ys)  vsubst ys y1 y2 X"

definition vsubstAbs where
"vsubstAbs ys y1 y2  substAbs ys (Var ys y1) y2"

abbreviation vsubstAbs_abbrev ("_ $[_ '/'/ _]'__" 200) where
"(A $[y1 // y2]_ys)  vsubstAbs ys y1 y2 A"

definition vsubstInp where
"vsubstInp ys y1 y2  substInp ys (Var ys y1) y2"

definition vsubstBinp where
"vsubstBinp ys y1 y2  substBinp ys (Var ys y1) y2"

abbreviation vsubstInp_abbrev ("_ %[_ '/'/ _]'__" 200) where
"(inp %[y1 // y2]_ys)  vsubstInp ys y1 y2 inp"

abbreviation vsubstBinp_abbrev ("_ %%[_ '/'/ _]'__" 200) where
"(binp %%[y1 // y2]_ys)  vsubstBinp ys y1 y2 binp"

lemma vsubstInp_def2:
"(inp %[y1 // y2]_ys) = lift (vsubst ys y1 y2) inp"
unfolding vsubstInp_def vsubst_def
by(auto simp add: substInp_def2)

lemma vsubstBinp_def2:
"(binp %%[y1 // y2]_ys) = lift (vsubstAbs ys y1 y2) binp"
unfolding vsubstBinp_def vsubstAbs_def
by(auto simp add: substBinp_def2)

definition vsubstEnv where
"vsubstEnv ys y1 y2  substEnv ys (Var ys y1) y2"

abbreviation vsubstEnv_abbrev ("_ &[_ '/'/ _]'__" 200) where
"(rho &[y1 // y2]_ys)  vsubstEnv ys y1 y2 rho"

theorem vsubstEnv_def2:
"(rho &[y1 // y]_ys) =
 (λxs x. case rho xs x of
           None  if (xs = ys  x = y) then Some (Var ys y1) else None
          |Some X  Some (X #[y1 // y]_ys))"
unfolding vsubstEnv_def vsubst_def by(auto simp add: substEnv_def2)

definition goodPar where
"goodPar P  ( X  termsOf P. good X) 
              ( A  absOf P. goodAbs A) 
              ( rho  envsOf P. goodEnv rho)"

lemma Par_preserves_good[simp]:
assumes "!! X. X  set XL  good X"
and "!! A. A  set AL   goodAbs A"
and "!! rho. rho  set rhoL  goodEnv rho"
shows "goodPar (Par xL XL AL rhoL)"
using assms unfolding goodPar_def by auto

lemma termsOf_preserves_good[simp]:
assumes "goodPar P" and "X : termsOf P"
shows "good X"
using assms unfolding goodPar_def by auto

lemma absOf_preserves_good[simp]:
assumes "goodPar P" and "A : absOf P"
shows "goodAbs A"
using assms unfolding goodPar_def by auto

lemma envsOf_preserves_good[simp]:
assumes "goodPar P" and "rho : envsOf P"
shows "goodEnv rho"
using assms unfolding goodPar_def by blast

lemmas param_simps =
termsOf.simps absOf.simps envsOf.simps
Par_preserves_good
termsOf_preserves_good absOf_preserves_good envsOf_preserves_good

subsection ‹Items versus quasi-items modulo alpha›

text‹Here we ``close the accounts" (for a while) with quasi-items  --
 beyond this subsection, there will not be any theorem that mentions
 quasi-items, except much later when we deal with iteration principles
 (and need to briefly switch back to quasi-terms in order to define the needed
 iterative map by the universality of the alpha-quotient).›

subsubsection ‹For terms›

lemma alphaGood_equivP: "equivP qGood alphaGood"
unfolding equivP_def reflP_def symP_def transP_def alphaGood_def
using alpha_refl alpha_sym alpha_trans by blast

lemma univ_asTerm_alphaGood[simp]:
assumes *: "congruentP alphaGood f" and **: "qGood X"
shows "univ f (asTerm X) = f X"
by (metis assms alphaGood_equivP asTerm_def univ_commute)

corollary univ_asTerm_alpha[simp]:
assumes *: "congruentP alpha f" and **: "qGood X"
shows "univ f (asTerm X) = f X"
apply(rule univ_asTerm_alphaGood)
using assms unfolding alphaGood_def congruentP_def by auto

lemma pick_inj_on_good: "inj_on pick (Collect good)"
unfolding good_def using alphaGood_equivP equivP_pick_inj_on by auto

lemma pick_injective_good[simp]:
"good X; good Y  (pick X = pick Y) = (X = Y)"
using pick_inj_on_good unfolding inj_on_def by auto

lemma good_imp_qGood_pick:
"good X  qGood (pick X)"
unfolding good_def
by (metis alphaGood_equivP equivP_pick_preserves)

lemma qGood_iff_good_asTerm:
"good (asTerm qX) = qGood qX"
unfolding good_def asTerm_def
using alphaGood_equivP proj_in_iff by fastforce

lemma pick_asTerm:
assumes "qGood qX"
shows "pick (asTerm qX) #= qX"
by (metis (full_types) alphaGood_def alphaGood_equivP asTerm_def assms pick_proj)

lemma asTerm_pick:
assumes "good X"
shows "asTerm (pick X) = X"
by (metis alphaGood_equivP asTerm_def assms good_def proj_pick)

lemma pick_alpha: "good X  pick X #= pick X"
using good_imp_qGood_pick alpha_refl by auto

lemma alpha_imp_asTerm_equal:
assumes "qGood qX" and "qX #= qY"
shows "asTerm qX = asTerm qY"
proof-
  have "alphaGood qX qY" unfolding alphaGood_def using assms
  by (metis alpha_preserves_qGood)
  thus ?thesis unfolding asTerm_def using alphaGood_equivP proj_iff
  by (metis alpha_preserves_qGood1 assms)
qed

lemma asTerm_equal_imp_alpha:
assumes "qGood qX" and "asTerm qX = asTerm qY"
shows "qX #= qY"
by (metis alphaAll_sym alphaAll_trans assms pick_asTerm qGood_iff_good_asTerm)

lemma asTerm_equal_iff_alpha:
assumes "qGood qX  qGood qY"
shows "(asTerm qX = asTerm qY) = (qX #= qY)"
by (metis alpha_imp_asTerm_equal alpha_sym asTerm_equal_imp_alpha assms)

lemma pick_alpha_iff_equal:
assumes "good X" and "good Y"
shows "pick X #= pick Y  X = Y"
by (metis asTerm_equal_iff_alpha asTerm_pick assms good_imp_qGood_pick)

lemma pick_swap_qSwap:
assumes "good X"
shows "pick (X #[x1  x2]_xs) #= ((pick X) #[[x1  x2]]_xs)"
by (metis assms good_imp_qGood_pick pick_asTerm qSwap_preserves_qGood1 swap_def)

lemma asTerm_qSwap_swap:
assumes "qGood qX"
shows "asTerm (qX #[[x1  x2]]_xs) = ((asTerm qX) #[x1  x2]_xs)"
 by (simp add: alpha_imp_asTerm_equal alpha_sym assms local.swap_def 
pick_asTerm qSwap_preserves_alpha qSwap_preserves_qGood1) 

lemma fresh_asTerm_qFresh:
assumes "qGood qX"
shows "fresh xs x (asTerm qX) = qFresh xs x qX"
by (simp add: assms fresh_def pick_asTerm qFresh_preserves_alpha)
 
(* Note that fresh and skel commute with pick by definition, so we only need
  to prove they commute with asTerm.  *)

lemma skel_asTerm_qSkel:
assumes "qGood qX"
shows "skel (asTerm qX) = qSkel qX"
by (simp add: alpha_qSkel assms pick_asTerm skel_def)
 
lemma double_swap_qSwap:
assumes "good X"
shows "qGood (((pick X) #[[x  y]]_zs) #[[x'  y']]_zs') 
       ((X #[x  y]_zs) #[x'  y']_zs') = asTerm (((pick X) #[[x  y]]_zs) #[[x'  y']]_zs')"
by (simp add: asTerm_qSwap_swap assms 
    good_imp_qGood_pick local.swap_def qSwap_preserves_qGood1)

lemma fresh_swap_qFresh_qSwap:
assumes "good X"
shows "fresh xs x (X #[y1  y2]_ys) = qFresh xs x ((pick X) #[[y1  y2]]_ys)"
by (simp add: assms 
    fresh_asTerm_qFresh good_imp_qGood_pick local.swap_def qSwap_preserves_qGood)

subsubsection ‹For abstractions›

lemma alphaAbsGood_equivP: "equivP qGoodAbs alphaAbsGood"
unfolding equivP_def reflP_def symP_def transP_def alphaAbsGood_def
using alphaAbs_refl alphaAbs_sym alphaAbs_trans by blast

lemma univ_asAbs_alphaAbsGood[simp]:
assumes "fAbs respectsP alphaAbsGood" and "qGoodAbs A"
shows "univ fAbs (asAbs A) = fAbs A"
by (metis assms alphaAbsGood_equivP asAbs_def univ_commute)

corollary univ_asAbs_alphaAbs[simp]:
assumes *: "fAbs respectsP alphaAbs" and **: "qGoodAbs A"
shows "univ fAbs (asAbs A) = fAbs A"
apply(rule univ_asAbs_alphaAbsGood)
using assms unfolding alphaAbsGood_def congruentP_def by auto

lemma pick_inj_on_goodAbs: "inj_on pick (Collect goodAbs)"
unfolding goodAbs_def using alphaAbsGood_equivP equivP_pick_inj_on by auto

lemma pick_injective_goodAbs[simp]:
"goodAbs A; goodAbs B  pick A = pick B  A = B"
using pick_inj_on_goodAbs unfolding inj_on_def by auto

lemma goodAbs_imp_qGoodAbs_pick:
"goodAbs A  qGoodAbs (pick A)"
unfolding goodAbs_def
using alphaAbsGood_equivP equivP_pick_preserves by fastforce

lemma qGoodAbs_iff_goodAbs_asAbs:
"goodAbs(asAbs qA) = qGoodAbs qA"
unfolding goodAbs_def asAbs_def
using alphaAbsGood_equivP proj_in_iff by fastforce

lemma pick_asAbs:
assumes "qGoodAbs qA"
shows "pick (asAbs qA) $= qA"
by (metis (full_types) alphaAbsGood_def alphaAbsGood_equivP asAbs_def assms pick_proj)

lemma asAbs_pick:
assumes "goodAbs A"
shows "asAbs (pick A) = A"
by (metis alphaAbsGood_equivP asAbs_def assms goodAbs_def proj_pick)

lemma pick_alphaAbs: "goodAbs A  pick A $= pick A"
using goodAbs_imp_qGoodAbs_pick alphaAbs_refl by auto

lemma alphaAbs_imp_asAbs_equal:
assumes "qGoodAbs qA" and "qA $= qB"
shows "asAbs qA = asAbs qB"
by (metis (no_types, hide_lams) proj_iff alphaAbsGood_def alphaAbsGood_equivP 
 alphaAbs_preserves_qGoodAbs asAbs_def assms)

lemma asAbs_equal_imp_alphaAbs:
assumes "qGoodAbs qA" and "asAbs qA = asAbs qB"
shows "qA $= qB"
by (metis alphaAbs_refl 
  alphaAbs_sym alphaAbs_trans_twice assms pick_asAbs qGoodAbs_iff_goodAbs_asAbs)
 
lemma asAbs_equal_iff_alphaAbs:
assumes "qGoodAbs qA  qGoodAbs qB"
shows "(asAbs qA = asAbs qB) = (qA $= qB)"
by (metis alphaAbs_imp_asAbs_equal alphaAbs_preserves_qGoodAbs 
 asAbs_equal_imp_alphaAbs assms) 

lemma pick_alphaAbs_iff_equal:
assumes "goodAbs A" and "goodAbs B"
shows "(pick A $= pick B) = (A = B)"
using asAbs_equal_iff_alphaAbs asAbs_pick assms goodAbs_imp_qGoodAbs_pick by blast

lemma pick_swapAbs_qSwapAbs:
assumes "goodAbs A"
shows "pick (A $[x1  x2]_xs) $= ((pick A) $[[x1  x2]]_xs)"
by (simp add: assms goodAbs_imp_qGoodAbs_pick 
 pick_asAbs qSwapAbs_preserves_qGoodAbs swapAbs_def)
 
lemma asAbs_qSwapAbs_swapAbs:
assumes "qGoodAbs qA"
shows "asAbs (qA $[[x1  x2]]_xs) = ((asAbs qA) $[x1  x2]_xs)"
 by (simp add: alphaAbs_imp_asAbs_equal alphaAbs_sym assms pick_asAbs 
   qSwapAbs_preserves_alphaAbs 
  qSwapAbs_preserves_qGoodAbs1 swapAbs_def)

lemma freshAbs_asAbs_qFreshAbs:
assumes "qGoodAbs qA"
shows "freshAbs xs x (asAbs qA) = qFreshAbs xs x qA"
by (simp add: assms freshAbs_def pick_asAbs qFreshAbs_preserves_alphaAbs)

lemma skelAbs_asAbs_qSkelAbs:
assumes "qGoodAbs qA"
shows "skelAbs (asAbs qA) = qSkelAbs qA"
by (simp add: alphaAll_qSkelAll assms pick_asAbs skelAbs_def)

subsubsection ‹For inputs›

text ‹For unbound inputs:›

lemma pickInp_inj_on_goodInp: "inj_on pickInp (Collect goodInp)"
unfolding pickInp_def[abs_def] inj_on_def  
proof(safe, rule ext)
  fix inp inp' i
  assume good: "goodInp inp" "goodInp inp'" and *: "lift pick inp = lift pick inp'"
  show "inp i = inp' i"
  proof(cases "inp i")
    assume inp: "inp i = None"
    hence "lift pick inp i = None" by (auto simp add: lift_None)
    hence "lift pick inp' i = None" using * by simp
    hence "inp' i = None" by (auto simp add: lift_None)
    thus ?thesis using inp by simp
  next
    fix X assume inp: "inp i = Some X"
    hence "lift pick inp i = Some (pick X)" unfolding lift_def by simp
    hence "lift pick inp' i = Some (pick X)" using * by simp
    then obtain X' where inp': "inp' i = Some X'" and XX': "pick X = pick X'"
    unfolding lift_def by(cases "inp' i", auto)
    hence "good X  good X'"
    using inp good goodInp_def liftAll_def by (metis (hide_lams, full_types))
    hence "X = X'" using XX' by auto
    thus ?thesis unfolding inp inp' by simp
  qed
qed

lemma goodInp_imp_qGoodInp_pickInp:
assumes "goodInp inp"
shows "qGoodInp (pickInp inp)"
unfolding pickInp_def qGoodInp_def liftAll_def  
proof safe
  fix i qX assume "lift pick inp i = Some qX"
  then obtain X where inp: "inp i = Some X" and qX: "qX = pick X"
  unfolding lift_def by(cases "inp i", auto)
  hence "good X" using assms
  unfolding goodInp_def liftAll_def by simp
  thus "qGood qX" unfolding qX using good_imp_qGood_pick by auto
next
  fix xs   let ?Left = "{i. lift pick inp i  None}"
  have "?Left = {i. inp i  None}" by(force simp add: lift_None)
  thus "|?Left| <o |UNIV :: 'var set|" using assms unfolding goodInp_def by auto
qed

lemma qGoodInp_iff_goodInp_asInp:
"goodInp (asInp qinp) = qGoodInp qinp"
proof(unfold asInp_def)
  let ?inp = "lift asTerm qinp"
  {assume qgood_qinp: "qGoodInp qinp"
   have "goodInp ?inp"
   unfolding goodInp_def liftAll_def proof safe
     fix i X assume inp: "?inp i = Some X"
     then obtain qX where qinp: "qinp i = Some qX" and X: "X = asTerm qX"
     unfolding lift_def by(cases "qinp i", auto)
     hence "qGood qX"
     using qgood_qinp unfolding qGoodInp_def liftAll_def by auto
     thus "good X" using X qGood_iff_good_asTerm by auto
   next
     fix xs let ?Left = "{i. lift asTerm qinp i  None}"
     have "?Left = {i. qinp i  None}" by(auto simp add: lift_None)
     thus "|?Left| <o |UNIV :: 'var set|" using qgood_qinp unfolding qGoodInp_def by auto
   qed
  }
  moreover
  {assume good_inp: "goodInp ?inp"
   have "qGoodInp qinp"
   unfolding qGoodInp_def liftAll_def proof safe
     fix i qX assume qinp: "qinp i = Some qX"  let ?X = "asTerm qX"
     have inp: "?inp i = Some ?X" unfolding lift_def using qinp by simp
     hence "good ?X"
     using good_inp unfolding goodInp_def liftAll_def by auto
     thus "qGood qX" using qGood_iff_good_asTerm by auto
   next
     fix xs let ?Left = "{i. qinp i  None}"
     have "?Left = {i. lift asTerm qinp i  None}" by(auto simp add: lift_None)
     thus "|?Left| <o |UNIV :: 'var set|" using good_inp unfolding goodInp_def by auto
   qed
  }
  ultimately show "goodInp ?inp = qGoodInp qinp" by blast
qed

lemma pickInp_asInp:
assumes "qGoodInp qinp"
shows "pickInp (asInp qinp) %= qinp"
using assms unfolding pickInp_def asInp_def lift_comp  
by (smt CollectI alphaInp_def asTerm_equal_iff_alpha asTerm_pick case_prodI comp_apply liftAll2_def liftAll_def lift_def option.case(2) option.sel qGoodInp_def qGood_iff_good_asTerm 
sameDom_lift2)

lemma asInp_pickInp:
assumes "goodInp inp"
shows "asInp (pickInp inp) = inp"
unfolding asInp_def pickInp_def lift_comp
proof(rule ext)
  fix i  show "lift (asTerm  pick) inp i = inp i"
  unfolding lift_def proof(cases "inp i", simp+)
    fix X assume "inp i = Some X"
    hence "good X" using assms unfolding goodInp_def liftAll_def by simp
    thus "asTerm (pick X) = X" using asTerm_pick by auto
  qed   
qed

lemma pickInp_alphaInp:
assumes goodInp: "goodInp inp"
shows "pickInp inp %= pickInp inp"
using assms goodInp_imp_qGoodInp_pickInp alphaInp_refl by auto

lemma alphaInp_imp_asInp_equal:
assumes "qGoodInp qinp" and "qinp %= qinp'"
shows "asInp qinp = asInp qinp'"
unfolding asInp_def proof(rule ext)
  fix i show "lift asTerm qinp i = lift asTerm qinp' i"
  proof(cases "qinp i")
    assume Case1: "qinp i = None"
    hence "qinp' i = None"
    using assms unfolding alphaInp_def sameDom_def liftAll2_def by auto
    thus ?thesis using Case1 unfolding lift_def by simp
  next
    fix qX assume Case2: "qinp i = Some qX"
    then obtain qX' where qinp': "qinp' i = Some qX'"
    using assms unfolding alphaInp_def sameDom_def liftAll2_def by (cases "qinp' i", force)
    hence "qX #= qX'"
    using assms Case2 unfolding alphaInp_def sameDom_def liftAll2_def by auto
    moreover have "qGood qX" using assms Case2 unfolding qGoodInp_def liftAll_def by auto
    ultimately show ?thesis
    using Case2 qinp' alpha_imp_asTerm_equal unfolding lift_def by auto
  qed
qed

lemma asInp_equal_imp_alphaInp:
assumes "qGoodInp qinp" and "asInp qinp = asInp qinp'"
shows "qinp %= qinp'"
using assms unfolding alphaInp_def liftAll2_def sameDom_def
by simp (smt asInp_def asTerm_equal_iff_alpha liftAll_def lift_def option.case(2) 
  option.sel qGoodInp_def sameDom_def sameDom_lift2)  

lemma asInp_equal_iff_alphaInp:
"qGoodInp qinp  (asInp qinp = asInp qinp') = (qinp %= qinp')"
using asInp_equal_imp_alphaInp alphaInp_imp_asInp_equal by blast

lemma pickInp_alphaInp_iff_equal:
assumes "goodInp inp" and "goodInp inp'"
shows "(pickInp inp %= pickInp inp') = (inp = inp')"
by (metis alphaInp_imp_asInp_equal asInp_equal_imp_alphaInp 
 asInp_pickInp assms goodInp_imp_qGoodInp_pickInp)

lemma pickInp_swapInp_qSwapInp:
assumes "goodInp inp"
shows "pickInp (inp %[x1  x2]_xs) %= ((pickInp inp) %[[x1  x2]]_xs)"
using assms unfolding alphaInp_def sameDom_def liftAll2_def 
pickInp_def swapInp_def qSwapInp_def lift_comp
by (simp add: lift_None)  
(smt assms comp_apply goodInp_imp_qGoodInp_pickInp liftAll_def lift_def local.swap_def option.case_eq_if option.sel option.simps(3) pickInp_def 
pick_asTerm qGoodInp_def qSwap_preserves_qGood1) 

lemma asInp_qSwapInp_swapInp:
assumes "qGoodInp qinp"
shows "asInp (qinp %[[x1  x2]]_xs) = ((asInp qinp) %[x1  x2]_xs)"
proof- 
  {fix i qX assume "qinp i = Some qX"
  hence "qGood qX" using assms unfolding qGoodInp_def liftAll_def by auto
  hence "asTerm (qX #[[x1  x2]]_xs) = swap xs x1 x2 (asTerm qX)"
  by(auto simp add: asTerm_qSwap_swap)
  }
  thus ?thesis
  using assms 
  by (smt asInp_def comp_apply lift_comp lift_cong qSwapInp_def swapInp_def)
qed

lemma swapInp_def2:
"(inp %[x1  x2]_xs) = asInp ((pickInp inp) %[[x1  x2]]_xs)"
unfolding swapInp_def asInp_def pickInp_def qSwapInp_def lift_def swap_def
apply(rule ext) subgoal for i by (cases "inp i") auto .

lemma freshInp_def2:
"freshInp xs x inp = qFreshInp xs x (pickInp inp)"
unfolding freshInp_def qFreshInp_def pickInp_def lift_def fresh_def liftAll_def
apply(rule iff_allI) subgoal for i by (cases "inp i") auto . 

text ‹For bound inputs:›

lemma pickBinp_inj_on_goodBinp: "inj_on pickBinp (Collect goodBinp)"
unfolding pickBinp_def[abs_def] inj_on_def 
proof(safe, rule ext)
  fix binp binp' i
  assume good: "goodBinp binp" "goodBinp binp'" and *: "lift pick binp = lift pick binp'"
  show "binp i = binp' i"
  proof(cases "binp i")
    assume binp: "binp i = None"
    hence "lift pick binp i = None" by (auto simp add: lift_None)
    hence "lift pick binp' i = None" using * by simp
    hence "binp' i = None" by (auto simp add: lift_None)
    thus ?thesis using binp by simp
  next
    fix A assume binp: "binp i = Some A"
    hence "lift pick binp i = Some (pick A)" unfolding lift_def by simp
    hence "lift pick binp' i = Some (pick A)" using * by simp
    then obtain A' where binp': "binp' i = Some A'" and AA': "pick A = pick A'"
    unfolding lift_def by(cases "binp' i", auto)
    hence "goodAbs A  goodAbs A'"
    using binp good goodBinp_def liftAll_def by (metis (hide_lams, full_types))
    hence "A = A'" using AA' by auto
    thus ?thesis unfolding binp binp' by simp
  qed
qed

lemma goodBinp_imp_qGoodBinp_pickBinp:
assumes "goodBinp binp"
shows "qGoodBinp (pickBinp binp)"
unfolding pickBinp_def qGoodBinp_def liftAll_def proof safe
  fix i qA assume "lift pick binp i = Some qA"
  then obtain A where binp: "binp i = Some A" and qA: "qA = pick A"
  unfolding lift_def by(cases "binp i", auto)
  hence "goodAbs A" using assms
  unfolding goodBinp_def liftAll_def by simp
  thus "qGoodAbs qA" unfolding qA using goodAbs_imp_qGoodAbs_pick by auto
next
  fix xs   let ?Left = "{i. lift pick binp i  None}"
  have "?Left = {i. binp i  None}" by(force simp add: lift_None)
  thus "|?Left| <o |UNIV :: 'var set|" using assms unfolding goodBinp_def by auto
qed

lemma qGoodBinp_iff_goodBinp_asBinp:
"goodBinp (asBinp qbinp) = qGoodBinp qbinp"
proof(unfold asBinp_def)
  let ?binp = "lift asAbs qbinp"
  {assume qgood_qbinp: "qGoodBinp qbinp"
   have "goodBinp ?binp"
   unfolding goodBinp_def liftAll_def proof safe
     fix i A assume binp: "?binp i = Some A"
     then obtain qA where qbinp: "qbinp i = Some qA" and A: "A = asAbs qA"
     unfolding lift_def by(cases "qbinp i", auto)
     hence "qGoodAbs qA"
     using qgood_qbinp unfolding qGoodBinp_def liftAll_def by auto
     thus "goodAbs A" using A qGoodAbs_iff_goodAbs_asAbs by auto
   next
     fix xs let ?Left = "{i. lift asAbs qbinp i  None}"
     have "?Left = {i. qbinp i  None}" by(auto simp add: lift_None)
     thus "|?Left| <o |UNIV :: 'var set|" using qgood_qbinp unfolding qGoodBinp_def by auto
   qed
  }
  moreover
  {assume good_binp: "goodBinp ?binp"
   have "qGoodBinp qbinp"
   unfolding qGoodBinp_def liftAll_def proof safe
     fix i qA assume qbinp: "qbinp i = Some qA"  let ?A = "asAbs qA"
     have binp: "?binp i = Some ?A" unfolding lift_def using qbinp by simp
     hence "goodAbs ?A"
     using good_binp unfolding goodBinp_def liftAll_def by auto
     thus "qGoodAbs qA" using qGoodAbs_iff_goodAbs_asAbs by auto
   next
     fix xs let ?Left = "{i. qbinp i  None}"
     have "?Left = {i. lift asAbs qbinp i  None}" by(auto simp add: lift_None)
     thus "|?Left| <o |UNIV :: 'var set|" using good_binp unfolding goodBinp_def by auto
   qed
  }
  ultimately show "goodBinp ?binp = qGoodBinp qbinp" by blast
qed

lemma pickBinp_asBinp:
assumes "qGoodBinp qbinp"
shows "pickBinp (asBinp qbinp) %%= qbinp"
unfolding pickBinp_def asBinp_def lift_comp alphaBinp_def using sameDom_lift2  
by auto (smt assms comp_apply liftAll2_def liftAll_def 
lift_def option.sel option.simps(5) pick_asAbs qGoodBinp_def)

lemma asBinp_pickBinp:
assumes "goodBinp binp"
shows "asBinp (pickBinp binp) = binp"
unfolding asBinp_def pickBinp_def lift_comp 
apply(rule ext)
subgoal for i apply(cases "binp i") 
using assms asAbs_pick unfolding goodBinp_def liftAll_def lift_def by auto .

lemma pickBinp_alphaBinp:
assumes goodBinp: "goodBinp binp"
shows "pickBinp binp %%= pickBinp binp"
using assms goodBinp_imp_qGoodBinp_pickBinp alphaBinp_refl by auto

lemma alphaBinp_imp_asBinp_equal:
assumes "qGoodBinp qbinp" and "qbinp %%= qbinp'"
shows "asBinp qbinp = asBinp qbinp'"
unfolding asBinp_def proof(rule ext)
  fix i show "lift asAbs qbinp i = lift asAbs qbinp' i"
  proof(cases "qbinp i") 
    case None
    hence "qbinp' i = None"
    using assms unfolding alphaBinp_def sameDom_def liftAll2_def by auto
    thus ?thesis using None unfolding lift_def by simp
  next
    case (Some qA)
    then obtain qA' where qbinp': "qbinp' i = Some qA'"
    using assms unfolding alphaBinp_def sameDom_def liftAll2_def by (cases "qbinp' i", force)
    hence "qA $= qA'"
    using assms Some unfolding alphaBinp_def sameDom_def liftAll2_def by auto
    moreover have "qGoodAbs qA" using assms Some unfolding qGoodBinp_def liftAll_def by auto
    ultimately show ?thesis
    using Some qbinp' alphaAbs_imp_asAbs_equal unfolding lift_def by auto
  qed
qed

lemma asBinp_equal_imp_alphaBinp:
assumes "qGoodBinp qbinp" and "asBinp qbinp = asBinp qbinp'"
shows "qbinp %%= qbinp'"
using assms unfolding alphaBinp_def liftAll2_def sameDom_def
by simp (smt asAbs_equal_imp_alphaAbs asBinp_def liftAll_def 
lift_None lift_def option.inject option.simps(5) qGoodBinp_def)  

lemma asBinp_equal_iff_alphaBinp:
"qGoodBinp qbinp  (asBinp qbinp = asBinp qbinp') = (qbinp %%= qbinp')"
using asBinp_equal_imp_alphaBinp alphaBinp_imp_asBinp_equal by blast

lemma pickBinp_alphaBinp_iff_equal:
assumes "goodBinp binp" and "goodBinp binp'"
shows "(pickBinp binp %%= pickBinp binp') = (binp = binp')"
using assms goodBinp_imp_qGoodBinp_pickBinp asBinp_pickBinp pickBinp_alphaBinp 
by (metis asBinp_equal_iff_alphaBinp)

lemma pickBinp_swapBinp_qSwapBinp:
assumes "goodBinp binp"
shows "pickBinp (binp %%[x1  x2]_xs) %%= ((pickBinp binp) %%[[x1  x2]]_xs)"
using assms unfolding pickBinp_def swapBinp_def qSwapBinp_def lift_comp
alphaBinp_def sameDom_def liftAll2_def  
by (simp add: goodBinp_def liftAll_def lift_def option.case_eq_if pick_swapAbs_qSwapAbs)

lemma asBinp_qSwapBinp_swapBinp:
assumes "qGoodBinp qbinp"
shows "asBinp (qbinp %%[[x1  x2]]_xs) = ((asBinp qbinp) %%[x1  x2]_xs)"
unfolding asBinp_def swapBinp_def qSwapBinp_def lift_comp alphaBinp_def lift_def
apply(rule ext) subgoal for i  apply(cases "qbinp i")
using assms asAbs_qSwapAbs_swapAbs by (fastforce simp add: liftAll_def qGoodBinp_def)+ .

lemma swapBinp_def2:
"(binp %%[x1  x2]_xs) = asBinp ((pickBinp binp) %%[[x1  x2]]_xs)"
unfolding swapBinp_def asBinp_def pickBinp_def qSwapBinp_def lift_def swapAbs_def
apply (rule ext) subgoal for i by (cases "binp i") simp_all . 

lemma freshBinp_def2:
"freshBinp xs x binp = qFreshBinp xs x (pickBinp binp)"
unfolding freshBinp_def qFreshBinp_def pickBinp_def lift_def freshAbs_def liftAll_def
apply (rule iff_allI) subgoal for i by (cases "binp i") simp_all .  

(* Note that psubstInp and psubstBinp are discussed in the next subsubsection,
about environments.  *)

subsubsection ‹For environments›

(* Remember we do not have any "quasi-swap" for environments --
   we plan to prove most of the things concerning parallel substitution
   and environments for equivPalence classes directly. *)

lemma goodEnv_imp_qGoodEnv_pickE:
assumes "goodEnv rho"
shows "qGoodEnv (pickE rho)"
unfolding qGoodEnv_def pickE_def
apply(auto simp del: "not_None_eq")
using assms good_imp_qGood_pick unfolding liftAll_lift_comp comp_def   
by (auto simp: goodEnv_def liftAll_def lift_None)   

lemma qGoodEnv_iff_goodEnv_asEnv:
"goodEnv (asEnv qrho) = qGoodEnv qrho"
unfolding asEnv_def unfolding goodEnv_def liftAll_lift_comp comp_def
by (auto simp: qGoodEnv_def lift_None liftAll_def qGood_iff_good_asTerm)

lemma pickE_asEnv:
assumes "qGoodEnv qrho"
shows "pickE (asEnv qrho) &= qrho"
using assms 
by (auto simp: lift_None liftAll_def lift_def alphaEnv_def sameDom_def liftAll2_def
pick_asTerm qGoodEnv_def pickE_def asEnv_def split: option.splits) 

lemma asEnv_pickE:
assumes "goodEnv rho"  shows "asEnv (pickE rho) xs x = rho xs x"
using assms asTerm_pick 
by (cases "rho xs x") (auto simp: goodEnv_def liftAll_def asEnv_def pickE_def lift_comp lift_def)
 
lemma pickE_alphaEnv:
assumes goodEnv: "goodEnv rho"  shows "pickE rho &= pickE rho"
using assms goodEnv_imp_qGoodEnv_pickE alphaEnv_refl by auto

lemma alphaEnv_imp_asEnv_equal:
assumes "qGoodEnv qrho" and "qrho &= qrho'"
shows "asEnv qrho = asEnv qrho'"
apply (rule ext)+ subgoal for xs x  apply(cases "qrho xs x") 
using assms asTerm_equal_iff_alpha alpha_imp_asTerm_equal 
by (auto simp add: alphaEnv_def sameDom_def asEnv_def lift_def 
    qGoodEnv_def liftAll_def liftAll2_def option.case_eq_if split: option.splits)
   blast+ .

lemma asEnv_equal_imp_alphaEnv:
assumes "qGoodEnv qrho" and "asEnv qrho = asEnv qrho'"
shows "qrho &= qrho'"
using assms unfolding alphaEnv_def sameDom_def liftAll2_def
apply (simp add: asEnv_def lift_None lift_def qGoodEnv_def liftAll_def) 
by (smt asTerm_equal_imp_alpha option.sel option.simps(5) option.case_eq_if option.distinct(1)) 

lemma asEnv_equal_iff_alphaEnv:
"qGoodEnv qrho  (asEnv qrho = asEnv qrho') = (qrho &= qrho')"
using asEnv_equal_imp_alphaEnv alphaEnv_imp_asEnv_equal by blast

lemma pickE_alphaEnv_iff_equal:
assumes "goodEnv rho" and "goodEnv rho'"
shows "(pickE rho &= pickE rho') = (rho = rho')"
proof(rule iffI, safe, (rule ext)+)
  fix xs x
  assume alpha: "pickE rho &= pickE rho'"
  have qgood_rho: "qGoodEnv (pickE rho)" using assms goodEnv_imp_qGoodEnv_pickE by auto
  have "rho xs x = asEnv (pickE rho) xs x" using assms asEnv_pickE by fastforce
  also have " = asEnv (pickE rho') xs x"
  using qgood_rho alpha alphaEnv_imp_asEnv_equal by fastforce
  also have " = rho' xs x" using assms asEnv_pickE by fastforce
  finally show "rho xs x = rho' xs x" .
next
  have "qGoodEnv(pickE rho')" using assms goodEnv_imp_qGoodEnv_pickE by auto
  thus "pickE rho' &= pickE rho'" using alphaEnv_refl by auto
qed

lemma freshEnv_def2:
"freshEnv xs x rho = qFreshEnv xs x (pickE rho)"
unfolding freshEnv_def qFreshEnv_def pickE_def lift_def fresh_def liftAll_def
apply(cases "rho xs x") 
by (auto intro!: iff_allI) (metis map_option_case map_option_eq_Some)

lemma pick_psubst_qPsubst:
assumes "good X" and "goodEnv rho"
shows "pick (X #[rho]) #= ((pick X) #[[pickE rho]])"
by (simp add: assms goodEnv_imp_qGoodEnv_pickE good_imp_qGood_pick 
              pick_asTerm psubst_def qPsubst_preserves_qGood)
 
lemma pick_psubstAbs_qPsubstAbs:
assumes "goodAbs A" and "goodEnv rho"
shows "pick (A $[rho]) $= ((pick A) $[[pickE rho]])"
by (simp add: assms goodAbs_imp_qGoodAbs_pick goodEnv_imp_qGoodEnv_pickE pick_asAbs 
   psubstAbs_def qPsubstAbs_preserves_qGoodAbs)
 
lemma pickInp_psubstInp_qPsubstInp:
assumes good: "goodInp inp" and good_rho: "goodEnv rho"
shows "pickInp (inp %[rho]) %= ((pickInp inp) %[[pickE rho]])"
using assms unfolding pickInp_def psubstInp_def qPsubstInp_def lift_comp
unfolding alphaInp_def sameDom_def liftAll2_def
by (simp add: lift_None)  
   (smt comp_apply goodEnv_imp_qGoodEnv_pickE goodInp_imp_qGoodInp_pickInp liftAll_def lift_def map_option_case map_option_eq_Some option.sel pickInp_def 
   pick_asTerm psubst_def qGoodInp_def qPsubst_preserves_qGood)

lemma pickBinp_psubstBinp_qPsubstBinp:
assumes good: "goodBinp binp" and good_rho: "goodEnv rho"
shows "pickBinp (binp %%[rho]) %%= ((pickBinp binp) %%[[pickE rho]])"
using assms unfolding pickBinp_def psubstBinp_def qPsubstBinp_def lift_comp
unfolding alphaBinp_def sameDom_def liftAll2_def
by (simp add: lift_None)  
   (smt comp_apply goodBinp_def liftAll_def lift_def map_option_case map_option_eq_Some 
        option.sel pick_psubstAbs_qPsubstAbs)

subsubsection‹The structural alpha-equivPalence maps commute with the syntactic constructs›

lemma pick_Var_qVar:
"pick (Var xs x) #= qVar xs x"
unfolding Var_def using pick_asTerm by force  

lemma Op_asInp_asTerm_qOp:
assumes "qGoodInp qinp" and "qGoodBinp qbinp"
shows "Op delta (asInp qinp) (asBinp qbinp) = asTerm (qOp delta qinp qbinp)"
using assms pickInp_asInp pickBinp_asBinp unfolding Op_def 
by(auto simp add: asTerm_equal_iff_alpha) 

lemma qOp_pickInp_pick_Op:
assumes "goodInp inp" and "goodBinp binp"
shows "qOp delta (pickInp inp) (pickBinp binp) #= pick (Op delta inp binp)"
using assms goodInp_imp_qGoodInp_pickInp goodBinp_imp_qGoodBinp_pickBinp  
unfolding Op_def using pick_asTerm alpha_sym by force

lemma Abs_asTerm_asAbs_qAbs:
assumes "qGood qX"
shows "Abs xs x (asTerm qX) = asAbs (qAbs xs x qX)"
using assms pick_asTerm qAbs_preserves_alpha unfolding Abs_def  
by(force simp add: asAbs_equal_iff_alphaAbs) 

lemma qAbs_pick_Abs:
assumes "good X"
shows "qAbs xs x (pick X) $= pick (Abs xs x X)"
using assms good_imp_qGood_pick  pick_asAbs alphaAbs_sym unfolding Abs_def by force

lemmas qItem_versus_item_simps =
univ_asTerm_alphaGood univ_asAbs_alphaAbsGood
univ_asTerm_alpha univ_asAbs_alphaAbs
pick_injective_good pick_injective_goodAbs

subsection ‹All operators preserve the ``good'' predicate›

(* Note: some facts here simply do not hold as ``iff"s.  *)

lemma Var_preserves_good[simp]:
"good(Var xs x::('index,'bindex,'varSort,'var,'opSym)term)"
by (metis Var_def qGood.simps(1) qGood_iff_good_asTerm)

lemma Op_preserves_good[simp]:
assumes "goodInp inp" and "goodBinp binp"
shows "good(Op delta inp binp)"
using assms goodInp_imp_qGoodInp_pickInp goodBinp_imp_qGoodBinp_pickBinp
qGood_iff_good_asTerm unfolding Op_def by fastforce
 
lemma Abs_preserves_good[simp]:
assumes good: "good X"
shows "goodAbs(Abs xs x X)"
using assms good_imp_qGood_pick qGoodAbs_iff_goodAbs_asAbs
unfolding Abs_def by fastforce

lemmas Cons_preserve_good =
Var_preserves_good Op_preserves_good Abs_preserves_good

lemma swap_preserves_good[simp]:
assumes "good X"
shows "good (X #[x  y]_xs)"
using assms good_imp_qGood_pick qSwap_preserves_qGood qGood_iff_good_asTerm 
unfolding swap_def by fastforce

lemma swapAbs_preserves_good[simp]:
assumes "goodAbs A"
shows "goodAbs (A $[x  y]_xs)"
using assms goodAbs_imp_qGoodAbs_pick qSwapAbs_preserves_qGoodAbs qGoodAbs_iff_goodAbs_asAbs 
unfolding swapAbs_def by fastforce

lemma swapInp_preserves_good[simp]:
assumes "goodInp inp"
shows "goodInp (inp %[x  y]_xs)"
using assms    
by (auto simp: goodInp_def lift_def swapInp_def liftAll_def split: option.splits)  

lemma swapBinp_preserves_good[simp]:
assumes "goodBinp binp"
shows "goodBinp (binp %%[x  y]_xs)"
using assms    
by (auto simp: goodBinp_def lift_def swapBinp_def liftAll_def split: option.splits) 

lemma swapEnvDom_preserves_good:
assumes "goodEnv rho"
shows "goodEnv (swapEnvDom xs x y rho)" (is "goodEnv ?rho'")
unfolding goodEnv_def liftAll_def  proof safe
  fix zs z X'  assume rho': "?rho' zs z = Some X'"
  hence "rho zs (z @zs[x  y]_xs) = Some X'" unfolding swapEnvDom_def by simp
  thus "good X'" using assms unfolding goodEnv_def liftAll_def by simp
next
  fix xsa ys  let ?Left = "{ya. ?rho' ys ya  None}"
  have "|{y}  {ya. rho ys ya  None}| <o |UNIV :: 'var set|"
  using assms var_infinite_INNER card_of_Un_singl_ordLess_infinite
  unfolding goodEnv_def by fastforce
  hence "|{x,y}  {ya. rho ys ya  None}| <o |UNIV :: 'var set|"
  using var_infinite_INNER card_of_Un_singl_ordLess_infinite by fastforce
  moreover
  {have "?Left  {x,y}  {ya. rho ys ya  None}"
   unfolding swapEnvDom_def sw_def[abs_def] by auto
   hence "|?Left| ≤o |{x,y}  {ya. rho ys ya  None}|"
   using card_of_mono1 by auto
  }
  ultimately show "|?Left| <o |UNIV :: 'var set|" using ordLeq_ordLess_trans by blast
qed 

lemma swapEnvIm_preserves_good:
assumes "goodEnv rho"
shows "goodEnv (swapEnvIm xs x y rho)"
using assms unfolding goodEnv_def swapEnvIm_def liftAll_def
by (auto simp: lift_def split: option.splits)

lemma swapEnv_preserves_good[simp]:
assumes "goodEnv rho"
shows "goodEnv (rho &[x  y]_xs)"
unfolding swapEnv_def comp_def
using assms by(auto simp add: swapEnvDom_preserves_good swapEnvIm_preserves_good)

lemmas swapAll_preserve_good =
swap_preserves_good swapAbs_preserves_good
swapInp_preserves_good swapBinp_preserves_good
swapEnv_preserves_good

lemma psubst_preserves_good[simp]:
assumes  "goodEnv rho" and "good X"
shows "good (X #[rho])"
using assms good_imp_qGood_pick goodEnv_imp_qGoodEnv_pickE  
qPsubst_preserves_qGood qGood_iff_good_asTerm unfolding psubst_def by fastforce

lemma psubstAbs_preserves_good[simp]:
assumes good_rho: "goodEnv rho" and goodAbs_A: "goodAbs A"
shows "goodAbs (A $[rho])"
using assms goodAbs_A goodAbs_imp_qGoodAbs_pick  goodEnv_imp_qGoodEnv_pickE 
qPsubstAbs_preserves_qGoodAbs qGoodAbs_iff_goodAbs_asAbs unfolding psubstAbs_def by fastforce

lemma psubstInp_preserves_good[simp]:
assumes good_rho: "goodEnv rho" and good: "goodInp inp"
shows "goodInp (inp %[rho])"
using assms unfolding goodInp_def psubstInp_def liftAll_def 
by (auto simp add: lift_def split: option.splits)

lemma psubstBinp_preserves_good[simp]:
assumes good_rho: "goodEnv rho" and good: "goodBinp binp"
shows "goodBinp (binp %%[rho])"
using assms unfolding goodBinp_def psubstBinp_def liftAll_def 
by (auto simp add: lift_def split: option.splits) 

lemma psubstEnv_preserves_good[simp]:
assumes good: "goodEnv rho" and good': "goodEnv rho'"
shows "goodEnv (rho &[rho'])"
unfolding goodEnv_def liftAll_def
proof safe
  fix zs z X'
  assume *: "(rho &[rho']) zs z = Some X'"
  show "good X'"
  proof(cases "rho zs z")
    case None
    hence "rho' zs z = Some X'" using * unfolding psubstEnv_def by auto
    thus ?thesis using good' unfolding goodEnv_def liftAll_def by auto
  next
    case (Some X)
    hence "X' = (X #[rho'])" using * unfolding psubstEnv_def by auto
    moreover have "good X" using Some good unfolding goodEnv_def liftAll_def by auto
    ultimately show ?thesis using good' psubst_preserves_good by auto
  qed
next
  fix xs ys  let ?Left = "{y. (rho &[rho']) ys y  None}"
  let ?Left1 = "{y. rho ys y  None}"  let ?Left2 = "{y. rho' ys y  None}"
  have "|?Left1| <o |UNIV :: 'var set|  |?Left2| <o |UNIV :: 'var set|"
  using good good' unfolding goodEnv_def by simp
  hence "|?Left1  ?Left2| <o |UNIV :: 'var set|"
  using var_infinite_INNER card_of_Un_ordLess_infinite by auto
  moreover
  {have "?Left  ?Left1  ?Left2" unfolding psubstEnv_def by auto
   hence "|?Left| ≤o |?Left1  ?Left2|" using card_of_mono1 by auto
  }
  ultimately show "|?Left| <o |UNIV :: 'var set|" using ordLeq_ordLess_trans by blast
qed

lemmas psubstAll_preserve_good =
psubst_preserves_good psubstAbs_preserves_good
psubstInp_preserves_good psubstBinp_preserves_good
psubstEnv_preserves_good

lemma idEnv_preserves_good[simp]: "goodEnv idEnv"
unfolding goodEnv_def idEnv_def liftAll_def
using var_infinite_INNER finite_ordLess_infinite2 by auto

lemma updEnv_preserves_good[simp]:
assumes good_X: "good X" and good_rho: "goodEnv rho"
shows "goodEnv (rho [x  X]_xs)"
using assms unfolding updEnv_def goodEnv_def liftAll_def
proof safe
  fix ys y Y
  assume "good X" and "ys y Y. rho ys y = Some Y  good Y"
  and "(if ys = xs  y = x then Some X else rho ys y) = Some Y"
  thus "good Y"
  by(cases "ys = xs  y = x") auto
next
  fix ys
  let ?V' = "{y.  (if ys = xs  y = x then Some X else rho ys y)  None}"
  let ?V = "λ ys. {y. rho ys y  None}"
  assume " ys. |?V ys| <o |UNIV :: 'var set|"
  hence "|{x}  ?V ys| <o |UNIV :: 'var set|"
  using var_infinite_INNER card_of_Un_singl_ordLess_infinite by fastforce
  moreover
  {have "?V'  {x}  ?V ys" by auto
   hence "|?V'| ≤o |{x}  ?V ys|" using card_of_mono1 by auto
  }
  ultimately show "|?V'| <o |UNIV :: 'var set|" using ordLeq_ordLess_trans by blast
qed

lemma getEnv_preserves_good[simp]:
assumes "goodEnv rho" and "rho xs x = Some X"
shows "good X"
using assms unfolding goodEnv_def liftAll_def by simp

lemmas envOps_preserve_good =
idEnv_preserves_good updEnv_preserves_good
getEnv_preserves_good

lemma subst_preserves_good[simp]:
assumes "good X" and "good Y"
shows "good (Y #[X / x]_xs)"
unfolding subst_def
using assms by simp

lemma substAbs_preserves_good[simp]:
assumes "good X" and "goodAbs A"
shows "goodAbs (A $[X / x]_xs)"
unfolding substAbs_def
using assms by simp

lemma substInp_preserves_good[simp]:
assumes "good X" and "goodInp inp"
shows "goodInp (inp %[X / x]_xs)"
unfolding substInp_def using assms by simp

lemma substBinp_preserves_good[simp]:
assumes "good X" and "goodBinp binp"
shows "goodBinp (binp %%[X / x]_xs)"
unfolding substBinp_def using assms by simp

lemma substEnv_preserves_good[simp]:
assumes "good X" and "goodEnv rho"
shows "goodEnv (rho &[X / x]_xs)"
unfolding substEnv_def using assms by simp

lemmas substAll_preserve_good =
subst_preserves_good substAbs_preserves_good
substInp_preserves_good substBinp_preserves_good
substEnv_preserves_good

lemma vsubst_preserves_good[simp]:
assumes "good Y"
shows "good (Y #[x1 // x]_xs)"
unfolding vsubst_def using assms by simp

lemma vsubstAbs_preserves_good[simp]:
assumes "goodAbs A"
shows "goodAbs (A $[x1 // x]_xs)"
unfolding vsubstAbs_def using assms by simp

lemma vsubstInp_preserves_good[simp]:
assumes "goodInp inp"
shows "goodInp (inp %[x1 // x]_xs)"
unfolding vsubstInp_def using assms by simp

lemma vsubstBinp_preserves_good[simp]:
assumes "goodBinp binp"
shows "goodBinp (binp %%[x1 // x]_xs)"
unfolding vsubstBinp_def using assms by simp

lemma vsubstEnv_preserves_good[simp]:
assumes "goodEnv rho"
shows "goodEnv (rho &[x1 // x]_xs)"
unfolding vsubstEnv_def using assms by simp

lemmas vsubstAll_preserve_good =
vsubst_preserves_good vsubstAbs_preserves_good
vsubstInp_preserves_good vsubstBinp_preserves_good
vsubstEnv_preserves_good

lemmas all_preserve_good =
Cons_preserve_good
swapAll_preserve_good
psubstAll_preserve_good
envOps_preserve_good
substAll_preserve_good
vsubstAll_preserve_good

subsubsection ‹The syntactic operators are almost constructors›

text‹The only one that does not act precisely like a constructor is ``Abs".›

theorem Var_inj[simp]:
"(((Var xs x)::('index,'bindex,'varSort,'var,'opSym)term) = Var ys y) =
 (xs = ys  x = y)"
by (metis alpha_qVar_iff pick_Var_qVar qTerm.inject)

lemma Op_inj[simp]:
assumes "goodInp inp" and "goodBinp binp"
and "goodInp inp'" and "goodBinp binp'"
shows
"(Op delta inp binp = Op delta' inp' binp') =
 (delta = delta'  inp = inp'  binp = binp')"
using assms pickInp_alphaInp_iff_equal pickBinp_alphaBinp_iff_equal 
goodInp_imp_qGoodInp_pickInp goodBinp_imp_qGoodBinp_pickBinp 
unfolding Op_def by (fastforce simp: asTerm_equal_iff_alpha) 

text‹``Abs" is almost injective (``ainj"), with almost injectivity expressed
   in two ways:
   \\- maximally, using "forall" -- this is suitable for elimination of ``Abs" equalities;
   \\- minimally, using "exists" -- this is suitable for introduction of ``Abs" equalities.
›

lemma Abs_ainj_all:
assumes good: "good X" and good': "good X'"
shows
"(Abs xs x X = Abs xs' x' X') =
 (xs = xs' 
  ( y. (y = x  fresh xs y X)  (y = x'  fresh xs y X') 
        (X #[y  x]_xs) = (X' #[y  x']_xs)))"
proof-
  let ?qX = "pick X"  let ?qX' = "pick X'"
  have qgood: "qGood ?qX  qGood ?qX'" using good good' good_imp_qGood_pick by auto
  hence qgood_qXyx: " y. qGood (?qX #[[y  x]]_xs)"
  using qSwap_preserves_qGood by auto
  have "qGoodAbs(qAbs xs x ?qX)" using qgood by simp
  hence "(Abs xs x X = Abs xs' x' X') = (qAbs xs x ?qX $= qAbs xs' x' ?qX')"
  unfolding Abs_def by (auto simp add: asAbs_equal_iff_alphaAbs)
  also
  have " = (xs = xs' 
             ( y. (y = x  qFresh xs y ?qX)  (y = x'  qFresh xs y ?qX') 
                   (?qX #[[y  x]]_xs) #= (?qX' #[[y  x']]_xs)))"
  using qgood alphaAbs_qAbs_iff_all_equal_or_qFresh[of ?qX ?qX'] by blast
  also
  have " = (xs = xs' 
             ( y. (y = x  fresh xs y X)  (y = x'  fresh xs y X') 
                   (X #[y  x]_xs) = (X' #[y  x']_xs)))"
  unfolding fresh_def swap_def using qgood_qXyx by (auto simp add: asTerm_equal_iff_alpha)
  finally show ?thesis .
qed

lemma Abs_ainj_ex:
assumes good: "good X" and good': "good X'"
shows
"(Abs xs x X = Abs xs' x' X') =
 (xs = xs' 
  ( y. y  {x,x'}  fresh xs y X  fresh xs y X' 
        (X #[y  x]_xs) = (X' #[y  x']_xs)))"
proof-
  let ?qX = "pick X"  let ?qX' = "pick X'"
  have qgood: "qGood ?qX  qGood ?qX'" using good good' good_imp_qGood_pick by auto
  hence qgood_qXyx: " y. qGood (?qX #[[y  x]]_xs)"
  using qSwap_preserves_qGood by auto
  have "qGoodAbs(qAbs xs x ?qX)" using qgood by simp
  hence "(Abs xs x X = Abs xs' x' X') = (qAbs xs x ?qX $= qAbs xs' x' ?qX')"
  unfolding Abs_def by (auto simp add: asAbs_equal_iff_alphaAbs)
  also
  have " =  (xs = xs' 
              ( y. y  {x,x'}  qFresh xs y ?qX  qFresh xs y ?qX' 
                    (?qX #[[y  x]]_xs) #= (?qX' #[[y  x']]_xs)))"
  using qgood alphaAbs_qAbs_iff_ex_distinct_qFresh[of ?qX xs x xs' x' ?qX'] by blast
  also
  have " =  (xs = xs' 
               ( y. y  {x,x'}  fresh xs y X  fresh xs y X' 
                     (X #[y  x]_xs) = (X' #[y  x']_xs)))"
  unfolding fresh_def swap_def using qgood_qXyx asTerm_equal_iff_alpha by auto
  finally show ?thesis .
qed

lemma Abs_cong[fundef_cong]:
assumes good: "good X" and good': "good X'"
and y: "fresh xs y X" and y': "fresh xs y X'"
and eq: "(X #[y  x]_xs) = (X' #[y  x']_xs)"
shows "Abs xs x X = Abs xs x' X'"
proof-
  let ?qX = "pick X"  let ?qX' = "pick X'"
  have qgood: "qGood ?qX  qGood ?qX'" using good good' good_imp_qGood_pick by auto
  hence qgood_qXyx: " y. qGood (?qX #[[y  x]]_xs)"
  using qSwap_preserves_qGood by auto
  have qEq: "(?qX #[[y  x]]_xs) #= (?qX' #[[y  x']]_xs)"
  using eq unfolding fresh_def swap_def
  using qgood_qXyx asTerm_equal_iff_alpha by auto
  have "(qAbs xs x ?qX $= qAbs xs x' ?qX')"
  apply(rule alphaAbs_ex_equal_or_qFresh_imp_alphaAbs_qAbs)
  using qgood apply simp
  unfolding alphaAbs_ex_equal_or_qFresh_def using y y' qEq
  unfolding fresh_def by auto
  moreover have "qGoodAbs(qAbs xs x ?qX)" using qgood by simp
  ultimately show "Abs xs x X = Abs xs x' X'"
  unfolding Abs_def by (auto simp add: asAbs_equal_iff_alphaAbs)
qed

lemma Abs_swap_fresh:
assumes good_X: "good X" and fresh: "fresh xs x' X"
shows "Abs xs x X = Abs xs x' (X #[x'  x]_xs)"
proof-
  let ?x'x = "swap xs x' x"   let ?qx'x = "qSwap xs x' x"
  have good_pickX: "qGood (pick X)" using good_X good_imp_qGood_pick by auto
  hence good_qAbs_pickX: "qGoodAbs (qAbs xs x (pick X))" by simp
  have good_x'x_pickX: "qGood (?qx'x (pick X))"
  using good_pickX qSwap_preserves_qGood by auto
  (*  *)
  have "Abs xs x X = asAbs (qAbs xs x (pick X))" unfolding Abs_def by simp
  also
  {have "qAbs xs x (pick X) $= qAbs xs x' (?qx'x (pick X))"
   using good_pickX fresh unfolding fresh_def using qAbs_alphaAbs_qSwap_qFresh by fastforce
   moreover
   {have "?qx'x (pick X) #= pick (?x'x X)"
    using good_X by (auto simp add: pick_swap_qSwap alpha_sym)
    hence "qAbs xs x' (?qx'x (pick X)) $= qAbs xs x' (pick (?x'x X))"
    using good_x'x_pickX qAbs_preserves_alpha by fastforce
   }
   ultimately have "qAbs xs x (pick X) $= qAbs xs x' (pick (?x'x X))"
   using good_qAbs_pickX alphaAbs_trans by blast
   hence "asAbs (qAbs xs x (pick X)) = asAbs (qAbs xs x' (pick (?x'x X)))"
   using good_qAbs_pickX by (auto simp add: asAbs_equal_iff_alphaAbs)
  }
  also have "asAbs (qAbs xs x' (pick (?x'x X))) = Abs xs x' (?x'x X)"
  unfolding Abs_def by auto
  finally show ?thesis .
qed

lemma Var_diff_Op[simp]:
"Var xs x  Op delta inp binp"
by (simp add: Op_def Var_def asTerm_equal_iff_alpha)

lemma Op_diff_Var[simp]:
"Op delta inp binp  Var xs x"
using Var_diff_Op[of _ _ _ inp] by blast

theorem term_nchotomy:
assumes "good X"
shows
"( xs x. X = Var xs x) 
 ( delta inp binp. goodInp inp  goodBinp binp  X = Op delta inp binp)"
proof-
  let ?qX = "pick X"
  have good_qX: "qGood ?qX" using assms good_imp_qGood_pick by auto
  have X: "X = asTerm ?qX" using assms asTerm_pick by auto
  show ?thesis
  proof(cases "?qX")
    fix xs x  assume Case1: "?qX = qVar xs x"
    have "X = Var xs x" unfolding Var_def using X Case1 by simp
    thus ?thesis by blast
  next
    fix delta qinp qbinp assume Case2: "?qX = qOp delta qinp qbinp"
    hence good_qinp: "qGoodInp qinp  qGoodBinp qbinp" using good_qX by simp
    let ?inp = "asInp qinp"  let ?binp = "asBinp qbinp"
    have "qinp %= pickInp ?inp  qbinp %%= pickBinp ?binp"
    using good_qinp pickInp_asInp alphaInp_sym pickBinp_asBinp alphaBinp_sym by blast
    hence "qOp delta qinp qbinp #= qOp delta (pickInp ?inp) (pickBinp ?binp)" by simp
    hence "asTerm (qOp delta qinp qbinp) = Op delta ?inp ?binp"
    unfolding Op_def using Case2 good_qX by (auto simp add: asTerm_equal_iff_alpha)
    hence "X = Op delta ?inp ?binp" using X Case2 by auto
    moreover have "goodInp ?inp  goodBinp ?binp"
    using good_qinp qGoodInp_iff_goodInp_asInp qGoodBinp_iff_goodBinp_asBinp by auto
    ultimately show ?thesis by blast
  qed
qed

theorem abs_nchotomy:
assumes "goodAbs A"
shows " xs x X. good X  A = Abs xs x X"
by (metis Abs_asTerm_asAbs_qAbs asAbs_pick assms 
     goodAbs_imp_qGoodAbs_pick qGoodAbs.elims(2) qGood_iff_good_asTerm)
 
lemmas good_freeCons =
Op_inj Var_diff_Op Op_diff_Var

subsection ‹Properties lifted from quasi-terms to terms›

subsubsection ‹Simplification rules›

theorem swap_Var_simp[simp]:
"((Var xs x) #[y1  y2]_ys) = Var xs (x @xs[y1  y2]_ys)"
by (metis QuasiTerms_Swap_Fresh.qSwapAll_simps(1) Var_def asTerm_qSwap_swap qItem_simps(9))

lemma swap_Op_simp[simp]:
assumes "goodInp inp"  "goodBinp binp"
shows "((Op delta inp binp) #[x1  x2]_xs) =
       Op delta (inp %[x1  x2]_xs) (binp %%[x1  x2]_xs)"
by (metis Op_asInp_asTerm_qOp Op_def asTerm_qSwap_swap assms(1) assms(2) goodBinp_imp_qGoodBinp_pickBinp goodInp_imp_qGoodInp_pickInp qGood_qGoodInp qSwapBinp_preserves_qGoodBinp 
     qSwapInp_preserves_qGoodInp qSwap_qSwapInp swapBinp_def2 swapInp_def2)

lemma swapAbs_simp[simp]:
assumes "good X"
shows "((Abs xs x X) $[y1  y2]_ys) = Abs xs (x @xs[y1  y2]_ys) (X #[y1  y2]_ys)"
by (metis Abs_asTerm_asAbs_qAbs Abs_preserves_good alphaAbs_preserves_qGoodAbs2 asAbs_qSwapAbs_swapAbs assms goodAbs_imp_qGoodAbs_pick good_imp_qGood_pick local.Abs_def 
     local.swap_def qAbs_pick_Abs qSwapAbs.simps qSwap_preserves_qGood1)

lemmas good_swapAll_simps =
swap_Op_simp swapAbs_simp

theorem fresh_Var_simp[simp]:
"fresh ys y (Var xs x :: ('index,'bindex,'varSort,'var,'opSym)term) 
 (ys  xs  y  x)"
by (simp add: Var_def fresh_asTerm_qFresh)
 
lemma fresh_Op_simp[simp]:
assumes "goodInp inp" "goodBinp binp"
shows
"fresh xs x (Op delta inp binp) 
 (freshInp xs x inp  freshBinp xs x binp)"
by (metis Op_def Op_preserves_good assms(1) assms(2) freshBinp_def2 
freshInp_def2 fresh_asTerm_qFresh qFresh_qFreshInp qGood_iff_good_asTerm)
 
lemma freshAbs_simp[simp]:
assumes "good X"
shows "freshAbs ys y (Abs xs x X)  (ys = xs  y = x  fresh ys y X)"
proof-
  let ?fr = "fresh ys y"  let ?qfr = "qFresh ys y"
  let ?frA = "freshAbs ys y"  let ?qfrA = "qFreshAbs ys y"
  have "qGood (pick X)" using assms by(auto simp add: good_imp_qGood_pick)
  hence good_qAbs_pick_X: "qGoodAbs (qAbs xs x (pick X))"
  using assms good_imp_qGood_pick by auto
  (*  *)
  have "?frA (Abs xs x X) = ?qfrA ((pick o asAbs) (qAbs xs x (pick X)))"
  unfolding freshAbs_def Abs_def by simp
  also
  {have "(pick o asAbs) (qAbs xs x (pick X)) $= qAbs xs x (pick X)"
   using good_qAbs_pick_X pick_asAbs by fastforce
   hence "?qfrA ((pick o asAbs) (qAbs xs x (pick X))) = ?qfrA (qAbs xs x (pick X))"
   using good_qAbs_pick_X qFreshAbs_preserves_alphaAbs by blast
  }
  also have "?qfrA(qAbs xs x (pick X)) = (ys = xs  y = x  ?qfr (pick X))" by simp
  also have " = (ys = xs  y = x  ?fr X)" unfolding fresh_def by simp
  finally show ?thesis .
qed

lemmas good_freshAll_simps =
fresh_Op_simp freshAbs_simp

theorem skel_Var_simp[simp]:
"skel (Var xs x) = Branch Map.empty Map.empty"
by (metis alpha_qSkel pick_Var_qVar qSkel.simps(1) skel_def) 

lemma skel_Op_simp[simp]:
assumes "goodInp inp" and "goodBinp binp"
shows "skel (Op delta inp binp) = Branch (skelInp inp) (skelBinp binp)"
by (metis (no_types, lifting) alpha_qSkel assms 
      qOp_pickInp_pick_Op qSkel_qSkelInp skelBinp_def skelInp_def skel_def)

lemma skelAbs_simp[simp]:
assumes "good X"
shows "skelAbs (Abs xs x X) = Branch (λi. Some (skel X)) Map.empty"
by (metis alphaAll_qSkelAll assms qAbs_pick_Abs qSkelAbs.simps skelAbs_def skel_def)

lemmas good_skelAll_simps =
skel_Op_simp skelAbs_simp

lemma psubst_Var:
assumes "goodEnv rho"
shows "((Var xs x) #[rho]) =
        (case rho xs x of None  Var xs x
                         |Some X  X)"
proof-
  let ?X = "Var xs x"  let ?qX = "qVar xs x"
  let ?qrho = "pickE rho"
  have good_qX: "qGood ?qX" using assms by simp
  moreover have good_qrho: "qGoodEnv ?qrho" using assms goodEnv_imp_qGoodEnv_pickE by auto
  ultimately have good_qXrho: "qGood (?qX #[[?qrho]])"
  using assms qPsubst_preserves_qGood by(auto simp del: qGoodAll_simps qPsubst.simps)
  (*  *)
  have "(?X #[rho]) = asTerm ((pick (asTerm ?qX)) #[[?qrho]])"
  unfolding Var_def psubst_def by simp
  also
  {have "?qX  #= pick (asTerm ?qX)" using good_qX pick_asTerm alpha_sym by fastforce
   hence "(?qX #[[?qrho]]) #= ((pick (asTerm ?qX)) #[[?qrho]])"
   using good_qrho good_qX qPsubst_preserves_alpha1[of _ ?qX] by fastforce
   hence "asTerm ((pick (asTerm ?qX))  #[[?qrho]]) = asTerm (?qX #[[?qrho]])"
   using good_qXrho asTerm_equal_iff_alpha[of "?qX #[[?qrho]]"] by blast
  }
  also have "asTerm (?qX #[[?qrho]]) =
             asTerm (case ?qrho xs x of None  qVar xs x
                                       |Some qY  qY)" unfolding Var_def by simp
  finally have 1: "(?X #[rho]) =  asTerm (case ?qrho xs x of None  qVar xs x
                                                            |Some qY  qY)" .
  show ?thesis
  proof(cases "rho xs x")
    assume Case1: "rho xs x = None"
    hence "?qrho xs x = None" unfolding pickE_def lift_def by simp
    thus ?thesis using 1 Case1 unfolding Var_def by simp
  next
    fix X assume Case2: "rho xs x = Some X"
    hence "good X" using assms unfolding goodEnv_def liftAll_def by auto
    hence "asTerm (pick X) = X" using asTerm_pick by auto
    moreover have qrho: "?qrho xs x = Some (pick X)"
    using Case2 unfolding pickE_def lift_def by simp
    ultimately show ?thesis using 1 Case2 unfolding Var_def by simp
  qed
qed

corollary psubst_Var_simp1[simp]:
assumes "goodEnv rho" and "rho xs x = None"
shows "((Var xs x) #[rho]) = Var xs x"
using assms by(simp add: psubst_Var)

corollary psubst_Var_simp2[simp]:
assumes "goodEnv rho" and "rho xs x = Some X"
shows "((Var xs x) #[rho]) = X"
using assms by(simp add: psubst_Var)

lemma psubst_Op_simp[simp]:
assumes good_inp: "goodInp inp"  "goodBinp binp"
and good_rho: "goodEnv rho"
shows
"((Op delta inp binp) #[rho]) = Op delta (inp %[rho]) (binp %%[rho])"
proof-
  let ?qrho = "pickE rho"
  let ?sbs = "psubst rho"   let ?qsbs = "qPsubst ?qrho"
  let ?sbsI = "psubstInp rho"  let ?qsbsI = "qPsubstInp ?qrho"
  let ?sbsB = "psubstBinp rho"  let ?qsbsB = "qPsubstBinp ?qrho"
  let ?op = "Op delta"   let ?qop = "qOp delta"
  have good_qop_pickInp_inp: "qGood (?qop (pickInp inp) (pickBinp binp))"
  using good_inp goodInp_imp_qGoodInp_pickInp
                 goodBinp_imp_qGoodBinp_pickBinp by auto
  hence "qGood ((pick o asTerm) (?qop (pickInp inp) (pickBinp binp)))"
  using good_imp_qGood_pick qGood_iff_good_asTerm by fastforce
  moreover have good_qrho: "qGoodEnv ?qrho"
  using good_rho goodEnv_imp_qGoodEnv_pickE by auto
  ultimately have good: "qGood (?qsbs((pick o asTerm) (?qop (pickInp inp) (pickBinp binp))))"
  using qPsubst_preserves_qGood by auto
  (*  *)
  have "?sbs (?op inp binp) =
        asTerm (?qsbs ((pick o asTerm) (?qop (pickInp inp) (pickBinp binp))))"
  unfolding psubst_def Op_def by simp
  also
  {have "(pick o asTerm) (?qop (pickInp inp) (pickBinp binp)) #=
         ?qop (pickInp inp) (pickBinp binp)"
   using good_qop_pickInp_inp pick_asTerm by fastforce
   hence "?qsbs((pick o asTerm) (?qop (pickInp inp) (pickBinp binp))) #=
          ?qsbs(?qop (pickInp inp) (pickBinp binp))"
   using good_qop_pickInp_inp good_qrho qPsubst_preserves_alpha1 by fastforce
   moreover have "?qsbs (?qop (pickInp inp) (pickBinp binp)) =
                  ?qop (?qsbsI (pickInp inp)) (?qsbsB (pickBinp binp))" by simp
   moreover
   {have "?qsbsI (pickInp inp) %= pickInp (?sbsI inp) 
          ?qsbsB (pickBinp binp) %%= pickBinp (?sbsB binp)"
    using good_rho good_inp pickInp_psubstInp_qPsubstInp[of inp rho]
          pickBinp_psubstBinp_qPsubstBinp[of binp rho] alphaInp_sym alphaBinp_sym by auto
    hence "?qop (?qsbsI (pickInp inp)) (?qsbsB (pickBinp binp)) #=
           ?qop (pickInp (?sbsI inp)) (pickBinp (?sbsB binp))" by simp
   }
   ultimately have "?qsbs((pick o asTerm) (?qop (pickInp inp) (pickBinp binp))) #=
                    ?qop (pickInp (?sbsI inp)) (pickBinp (?sbsB binp))"
   using good alpha_trans by force
   hence "asTerm (?qsbs((pick o asTerm) (?qop (pickInp inp) (pickBinp binp)))) =
          asTerm (?qop (pickInp (?sbsI inp)) (pickBinp (?sbsB binp)))"
   using good by (auto simp add: asTerm_equal_iff_alpha)
  }
  also have "asTerm (?qop (pickInp (?sbsI inp)) (pickBinp (?sbsB binp))) =
             ?op (?sbsI inp) (?sbsB binp)" unfolding Op_def by simp
  finally show ?thesis .
qed

lemma psubstAbs_simp[simp]:
assumes good_X: "good X" and good_rho: "goodEnv rho" and
        x_fresh_rho: "freshEnv xs x rho"
shows "((Abs xs x X) $[rho]) = Abs xs x (X #[rho])"
proof-
  let ?qrho = "pickE rho"
  let ?sbs = "psubst rho"  let ?qsbs = "qPsubst ?qrho"
  let ?sbsA = "psubstAbs rho"  let ?qsbsA = "qPsubstAbs ?qrho"
  have good_qrho: "qGoodEnv ?qrho"
  using good_rho goodEnv_imp_qGoodEnv_pickE by auto
  have good_pick_X: "qGood (pick X)" using good_X good_imp_qGood_pick by auto
  hence good_qsbs_pick_X: "qGood(?qsbs (pick X))"
  using good_qrho qPsubst_preserves_qGood by auto
  have good_qAbs_pick_X: "qGoodAbs (qAbs xs x (pick X))"
  using good_X good_imp_qGood_pick by auto
  hence "qGoodAbs ((pick o asAbs) (qAbs xs x (pick X)))"
  using goodAbs_imp_qGoodAbs_pick qGoodAbs_iff_goodAbs_asAbs by fastforce
  hence good: "qGoodAbs (?qsbsA ((pick o asAbs) (qAbs xs x (pick X))))"
  using good_qrho qPsubstAbs_preserves_qGoodAbs by auto
  have x_fresh_qrho: "qFreshEnv xs x ?qrho"
  using x_fresh_rho unfolding freshEnv_def2 by auto
  (*  *)
  have "?sbsA (Abs xs x X) = asAbs (?qsbsA ((pick o asAbs) (qAbs xs x (pick X))))"
  unfolding psubstAbs_def Abs_def by simp
  also
  {have "(pick o asAbs) (qAbs xs x (pick X)) $= qAbs xs x (pick X)"
   using good_qAbs_pick_X pick_asAbs by fastforce
   hence "?qsbsA((pick o asAbs) (qAbs xs x (pick X))) $= ?qsbsA(qAbs xs x (pick X))"
   using good_qAbs_pick_X good_qrho qPsubstAbs_preserves_alphaAbs1 by force
   moreover have "?qsbsA(qAbs xs x (pick X)) $= qAbs xs x (?qsbs (pick X))"
   using qFresh_qPsubst_commute_qAbs good_pick_X good_qrho x_fresh_qrho by auto
   moreover
   {have "?qsbs (pick X) #= pick (?sbs X)"
    using good_rho good_X pick_psubst_qPsubst alpha_sym by fastforce
    hence "qAbs xs x (?qsbs (pick X)) $= qAbs xs x (pick (?sbs X))"
    using good_qsbs_pick_X qAbs_preserves_alpha by fastforce
   }
   ultimately
   have "?qsbsA((pick o asAbs) (qAbs xs x (pick X))) $= qAbs xs x (pick (?sbs X))"
   using good alphaAbs_trans by blast
   hence "asAbs (?qsbsA((pick o asAbs) (qAbs xs x (pick X)))) =
          asAbs (qAbs xs x (pick (?sbs X)))"
   using good asAbs_equal_iff_alphaAbs by auto
  }
  also have "asAbs (qAbs xs x (pick (?sbs X))) = Abs xs x (?sbs X)"
  unfolding Abs_def by simp
  finally show ?thesis .
qed

lemmas good_psubstAll_simps =
psubst_Var_simp1 psubst_Var_simp2
psubst_Op_simp psubstAbs_simp

theorem getEnv_idEnv[simp]: "idEnv xs x = None"
unfolding idEnv_def by simp

lemma getEnv_updEnv[simp]:
"(rho [x  X]_xs) ys y = (if ys = xs  y = x then Some X else rho ys y)"
unfolding updEnv_def by auto

theorem getEnv_updEnv1:
"ys  xs  y  x  (rho [x  X]_xs) ys y = rho ys y"
by auto

theorem getEnv_updEnv2:
"(rho [x  X]_xs) xs x = Some X"
by auto

lemma subst_Var_simp1[simp]:
assumes "good Y"
and "ys  xs  y  x"
shows "((Var xs x) #[Y / y]_ys) = Var xs x"
using assms unfolding subst_def by auto

lemma subst_Var_simp2[simp]:
assumes "good Y"
shows "((Var xs x) #[Y / x]_xs) = Y"
using assms unfolding subst_def by auto

lemma subst_Op_simp[simp]:
assumes "good Y"
and "goodInp inp" and "goodBinp binp"
shows
"((Op delta inp binp) #[Y / y]_ys) =
 Op delta (inp %[Y / y]_ys) (binp %%[Y / y]_ys)"
using assms unfolding subst_def substInp_def substBinp_def by auto

lemma substAbs_simp[simp]:
assumes good: "good Y" and good_X: "good X" and
        x_dif_y: "xs  ys  x  y" and x_fresh: "fresh xs x Y"
shows "((Abs xs x X) $[Y / y]_ys) = Abs xs x (X #[Y / y]_ys)"
proof-
  have "freshEnv xs x (idEnv [y  Y]_ys)" unfolding freshEnv_def liftAll_def
  using x_dif_y x_fresh by auto
  thus ?thesis using assms unfolding subst_def substAbs_def by auto
qed

lemmas good_substAll_simps =
subst_Var_simp1 subst_Var_simp2
subst_Op_simp substAbs_simp

theorem vsubst_Var_simp[simp]:
"((Var xs x) #[y1 // y]_ys) = Var xs (x @xs[y1 / y]_ys)"
unfolding vsubst_def
apply(case_tac "ys = xs  y = x") by simp_all

lemma vsubst_Op_simp[simp]:
assumes "goodInp inp" and "goodBinp binp"
shows
"((Op delta inp binp) #[y1 // y]_ys) =
 Op delta (inp %[y1 // y]_ys) (binp %%[y1 // y]_ys)"
using assms unfolding vsubst_def vsubstInp_def vsubstBinp_def by auto

lemma vsubstAbs_simp[simp]:
assumes "good X" and
        "xs  ys  x  {y,y1}"
shows "((Abs xs x X) $[y1 // y]_ys) = Abs xs x (X #[y1 // y]_ys)"
using assms unfolding vsubst_def vsubstAbs_def by auto

lemmas good_vsubstAll_simps =
vsubst_Op_simp vsubstAbs_simp

lemmas good_allOpers_simps =
good_swapAll_simps
good_freshAll_simps
good_skelAll_simps
good_psubstAll_simps
good_substAll_simps
good_vsubstAll_simps

subsubsection ‹The ability to pick fresh variables›

lemma single_non_fresh_ordLess_var:
"good X  |{x. ¬ fresh xs x X}| <o |UNIV :: 'var set|"
unfolding fresh_def
by(auto simp add: good_imp_qGood_pick single_non_qFresh_ordLess_var)

lemma single_non_freshAbs_ordLess_var:
"goodAbs A  |{x. ¬ freshAbs xs x A}| <o |UNIV :: 'var set|"
unfolding freshAbs_def
by(auto simp add: goodAbs_imp_qGoodAbs_pick single_non_qFreshAbs_ordLess_var)

lemma obtain_fresh1:
fixes XS::"('index,'bindex,'varSort,'var,'opSym)term set" and
      Rho::"('index,'bindex,'varSort,'var,'opSym)env set" and rho
assumes Vvar: "|V| <o |UNIV :: 'var set|  finite V" and XSvar: "|XS| <o |UNIV :: 'var set|  finite XS" and
        good: " X  XS. good X" and
        Rhovar: "|Rho| <o |UNIV :: 'var set|  finite Rho" and RhoGood: " rho  Rho. goodEnv rho"
shows
" z. z  V 
 ( X  XS. fresh xs z X) 
 ( rho  Rho. freshEnv xs z rho)"
proof-
  let ?qXS = "pick ` XS"    let ?qRho = "pickE ` Rho"
  have "|?qXS| ≤o |XS|" using card_of_image by auto
  hence 1: "|?qXS| <o |UNIV :: 'var set|  finite ?qXS"
  using ordLeq_ordLess_trans card_of_ordLeq_finite XSvar by blast
  have "|?qRho| ≤o |Rho|" using card_of_image by auto
  hence 2: "|?qRho| <o |UNIV :: 'var set|  finite ?qRho"
  using ordLeq_ordLess_trans card_of_ordLeq_finite Rhovar by blast
  have 3: " qX  ?qXS. qGood qX" using good good_imp_qGood_pick by auto
  have " qrho  ?qRho. qGoodEnv qrho" using RhoGood goodEnv_imp_qGoodEnv_pickE by auto
  then obtain z where
  "z  V  ( qX  ?qXS. qFresh xs z qX) 
   ( qrho  ?qRho. qFreshEnv xs z qrho)"
  using Vvar 1 2 3 obtain_qFreshEnv[of V ?qXS ?qRho] by fastforce
  thus ?thesis unfolding fresh_def freshEnv_def2 by auto
qed

lemma obtain_fresh:
fixes V::"'var set" and
      XS::"('index,'bindex,'varSort,'var,'opSym)term set" and
      AS::"('index,'bindex,'varSort,'var,'opSym)abs set" and
      Rho::"('index,'bindex,'varSort,'var,'opSym)env set"
assumes Vvar: "|V| <o |UNIV :: 'var set|  finite V" and
        XSvar: "|XS| <o |UNIV :: 'var set|  finite XS" and
        ASvar: "|AS| <o |UNIV :: 'var set|  finite AS" and
        Rhovar: "|Rho| <o |UNIV :: 'var set|  finite Rho" and
        good: " X  XS. good X" and
        ASGood: " A  AS. goodAbs A" and
        RhoGood: " rho  Rho. goodEnv rho"
shows
" z. z  V 
     ( X  XS. fresh xs z X) 
     ( A  AS. freshAbs xs z A) 
     ( rho  Rho. freshEnv xs z rho)"
proof-
  have XS: "|XS| <o |UNIV :: 'var set|" and AS: "|AS| <o |UNIV :: 'var set|"
  using XSvar ASvar finite_ordLess_var by auto
  let ?phi = "% A Y. (good Y  (EX ys y. A = Abs ys y Y))"
  {fix A assume "A  AS"
   hence "goodAbs A" using ASGood by simp
   hence "EX Y. ?phi A Y" using abs_nchotomy[of A] by auto
  }
  then obtain f where 1: "ALL A : AS. ?phi A (f A)"
  using bchoice[of AS ?phi] by auto
  let ?YS = "f ` AS"
  have 2: "ALL Y : ?YS. good Y" using 1 by simp
  have "|?YS| <=o |AS|" using card_of_image by auto
  hence "|?YS| <o |UNIV :: 'var set|"
  using AS ordLeq_ordLess_trans by blast
  hence "|XS Un ?YS| <o |UNIV :: 'var set|"
  using XS by (auto simp add: var_infinite_INNER card_of_Un_ordLess_infinite)
  then obtain z where z: "z  V"
  and XSYS: " X  XS Un ?YS. fresh xs z X"
  and Rho: " rho  Rho. freshEnv xs z rho"
  using Vvar Rhovar good 2 RhoGood
        obtain_fresh1[of V "XS Un ?YS" Rho xs] by blast
  moreover
  {fix A
   obtain Y where Y_def: "Y = f A" by blast
   assume "A : AS"
   hence "fresh xs z Y" unfolding Y_def using XSYS by simp
   moreover obtain ys y where Y: "good Y" and A: "A = Abs ys y Y"
   unfolding Y_def using A : AS 1 by auto
   ultimately have "freshAbs xs z A" unfolding A using z by auto
  }
  ultimately show ?thesis by auto
qed

subsubsection ‹Compositionality›

lemma swap_ident[simp]:
assumes "good X"
shows "(X #[x  x]_xs) = X"
using assms asTerm_pick qSwap_ident unfolding swap_def by auto

lemma swap_compose:
assumes good_X: "good X"
shows "((X #[x  y]_zs) #[x'  y']_zs') =
       ((X #[x'  y']_zs') #[(x @zs[x'  y']_zs')  (y @zs[x'  y']_zs')]_zs)"
using assms qSwap_compose[of _ _ _ _ _ _ "pick X"] by(auto simp add: double_swap_qSwap)

lemma swap_commute:
"good X; zs  zs'  {x,y}  {x',y'} = {} 
 ((X #[x  y]_zs) #[x'  y']_zs') = ((X #[x'  y']_zs') #[x  y]_zs)"
using swap_compose[of X  zs' x' y' zs x y] by(auto simp add: sw_def)

lemma swap_involutive[simp]:
assumes good_X: "good X"
shows "((X #[x  y]_zs) #[x  y]_zs) = X"
using assms asTerm_pick[of X] by (auto simp add: double_swap_qSwap)

theorem swap_sym: "(X #[x  y]_zs) = (X #[y  x]_zs)"
unfolding swap_def by(auto simp add: qSwap_sym)

lemma swap_involutive2[simp]:
assumes "good X"
shows "((X #[x  y]_zs) #[y  x]_zs) = X"
using assms by(simp add: swap_sym)

lemma swap_preserves_fresh[simp]:
assumes "good X"
shows "fresh xs (x @xs[y1  y2]_ys) (X #[y1  y2]_ys) = fresh xs x X"
unfolding fresh_def[of _ _ X] using assms qSwap_preserves_qFresh[of _ _ _ _ _ "pick X"]
by(auto simp add: fresh_swap_qFresh_qSwap)

lemma swap_preserves_fresh_distinct:
assumes "good X" and
       "xs  ys  x  {y1,y2}"
shows "fresh xs x (X #[y1  y2]_ys) = fresh xs x X"
unfolding fresh_def[of _ _ X] using assms  
by(auto simp: fresh_swap_qFresh_qSwap qSwap_preserves_qFresh_distinct)

lemma fresh_swap_exchange1:
assumes "good X"
shows "fresh xs x2 (X #[x1  x2]_xs) = fresh xs x1 X"
unfolding fresh_def[of _ _ X]
using assms by(auto simp: fresh_swap_qFresh_qSwap qFresh_qSwap_exchange1)

lemma fresh_swap_exchange2:
assumes "good X" and "{x1,x2}  var xs"
shows "fresh xs x2 (X #[x2  x1]_xs) = fresh xs x1 X"
using assms by(simp add: fresh_swap_exchange1 swap_sym)

(* Note: the lemmas swap_preserves_fresh_distinct, fresh_swap_exchange1 and
   fresh_swap_exchange2 do cover all possibilities of simplifying an
   expression of the form "fresh ys y (X #[x2 ∧ x1]_xs)".   *)

lemma fresh_swap_id[simp]:
assumes "good X" and "fresh xs x1 X" "fresh xs x2 X"
shows "(X #[x1  x2]_xs) = X"
by (metis (no_types, lifting)  assms alpha_imp_asTerm_equal alpha_qFresh_qSwap_id asTerm_pick   
      fresh_def good_imp_qGood_pick local.swap_def qSwap_preserves_qGood1)

lemma freshAbs_swapAbs_id[simp]:
assumes "goodAbs A" "freshAbs xs x1 A"  "freshAbs xs x2 A"
shows "(A $[x1  x2]_xs) = A"
using assms 
by (meson alphaAbs_qFreshAbs_qSwapAbs_id alphaAll_trans freshAbs_def goodAbs_imp_qGoodAbs_pick 
    pick_alphaAbs_iff_equal pick_swapAbs_qSwapAbs swapAbs_preserves_good)
 
lemma fresh_swap_compose:
assumes "good X" "fresh xs y X" "fresh xs z X"
shows "((X #[y  x]_xs) #[z  y]_xs) = (X #[z  x]_xs)"
using assms by (simp add: sw_def swap_compose)

lemma skel_swap:
assumes "good X"
shows "skel (X #[x1  x2]_xs) = skel X"
using assms by (metis alpha_qSkel pick_swap_qSwap qSkel_qSwap skel_def)

subsubsection ‹Compositionality for environments›

lemma swapEnv_ident[simp]:
assumes "goodEnv rho"
shows "(rho &[x  x]_xs) = rho"
using assms unfolding swapEnv_defs lift_def  
by (intro ext) (auto simp: option.case_eq_if) 

lemma swapEnv_compose:
assumes good: "goodEnv rho"
shows "((rho &[x  y]_zs) &[x'  y']_zs') =
       ((rho &[x'  y']_zs') &[(x @zs[x'  y']_zs')  (y @zs[x'  y']_zs')]_zs)"
proof(rule ext)+
  let ?xsw = "x @zs[x'  y']_zs'"  let ?ysw = "y @zs[x'  y']_zs'"
  let ?xswsw = "?xsw @zs[x'  y']_zs'"  let ?yswsw = "?ysw @zs[x'  y']_zs'"
  let ?rhosw1 = "rho &[x  y]_zs"   let ?rhosw11 = "?rhosw1 &[x'  y']_zs'"
  let ?rhosw2 = "rho &[x'  y']_zs'" let ?rhosw22 = "?rhosw2 &[?xsw  ?ysw]_zs"
  let ?Sw1 = "λX. (X #[x  y]_zs)"  let ?Sw11 = "λX. ((?Sw1 X) #[x'  y']_zs')"
  let ?Sw2 = "λX. (X #[x'  y']_zs')"  let ?Sw22 = "λX. ((?Sw2 X) #[?xsw  ?ysw]_zs)"
  fix us u
  let ?usw1 = "u @us [x'  y']_zs'" let ?usw11 = "?usw1 @us [x  y]_zs"
  let ?usw2 = "u @us [?xsw  ?ysw]_zs" let ?usw22 = "?usw2 @us [x'  y']_zs'"
  have "(?xsw @zs[x'  y']_zs') = x" and "(?ysw @zs[x'  y']_zs') = y" by auto
  have "?usw22 = (?usw1 @us[?xswsw  ?yswsw]_zs)" using sw_compose .
  hence *: "?usw22 = ?usw11" by simp
  show "?rhosw11 us u = ?rhosw22 us u"
  proof(cases "rho us ?usw11")
    case None
    hence "?rhosw11 us u = None" unfolding swapEnv_defs lift_def by simp
    also have " = ?rhosw22 us u"
    using None unfolding * swapEnv_defs lift_def by simp
    finally show ?thesis .
  next
    case (Some X)
    hence "good X" using good unfolding goodEnv_def liftAll_def by simp
    have "?rhosw11 us u = Some(?Sw11 X)" using Some unfolding swapEnv_defs lift_def by simp
    also have "?Sw11 X = ?Sw22 X"
    using ‹good X by(rule swap_compose)
    also have "Some(?Sw22 X) = ?rhosw22 us u"
    using Some unfolding * swapEnv_defs lift_def by simp
    finally show ?thesis .
  qed
qed

lemma swapEnv_commute:
"goodEnv rho; {x,y}  var zs; zs  zs'  {x,y}  {x',y'} = {} 
 ((rho &[x  y]_zs) &[x'  y']_zs') = ((rho &[x'  y']_zs') &[x  y]_zs)"
using swapEnv_compose[of rho zs' x' y' zs x y] by(auto simp add: sw_def)

lemma swapEnv_involutive[simp]:
assumes "goodEnv rho"
shows "((rho &[x  y]_zs) &[x  y]_zs) = rho"
using assms unfolding swapEnv_defs lift_def  
by (fastforce simp: option.case_eq_if) 

theorem swapEnv_sym: "(rho &[x  y]_zs) = (rho &[y  x]_zs)"
proof(intro ext)
  fix us u
  have *: "(u @us[x  y]_zs) = (u @us[y  x]_zs)" using sw_sym by fastforce
  show "(rho &[x  y]_zs) us u = (rho &[y  x]_zs) us u"
  unfolding swapEnv_defs lift_def *
  by(cases "rho us (u @us[y  x]_zs)") (auto simp: swap_sym)
qed

lemma swapEnv_involutive2[simp]:
assumes good: "goodEnv rho"
shows "((rho &[x  y]_zs) &[y  x]_zs) = rho"
using assms by(simp add: swapEnv_sym)

lemma swapEnv_preserves_freshEnv[simp]:
assumes good: "goodEnv rho"
shows "freshEnv xs (x @xs[y1  y2]_ys) (rho &[y1  y2]_ys) = freshEnv xs x rho"
proof-
 let ?xsw = "x @xs[y1  y2]_ys"  let ?xswsw = "?xsw @xs[y1  y2]_ys"
 let ?rhosw = "rho &[y1  y2]_ys"
 let ?Left = "freshEnv xs ?xsw ?rhosw"
 let ?Right = "freshEnv xs x rho"
 have "(?rhosw xs ?xsw = None) = (rho xs x = None)"
 unfolding freshEnv_def swapEnv_defs
 by(simp add: lift_None sw_involutive)
 moreover
 have "( zs z' Z'. ?rhosw zs z' = Some Z'  fresh xs ?xsw Z') =
       ( zs z Z. rho zs z = Some Z  fresh xs x Z)"
 proof(rule iff_allI, auto)
   fix zs z Z assume *: " z' Z'. ?rhosw zs z' = Some Z'  fresh xs ?xsw Z'"
   and **: "rho zs z = Some Z"  let ?z' = "z @zs[y1  y2]_ys"  let ?Z' = "Z #[y1  y2]_ys"
   have "?rhosw zs ?z' = Some ?Z'" using ** unfolding swapEnv_defs lift_def
   by(simp add: sw_involutive)
   hence "fresh xs ?xsw ?Z'" using * by simp
   moreover have "good Z" using ** good unfolding goodEnv_def liftAll_def by simp
   ultimately show "fresh xs x Z" using swap_preserves_fresh by auto
 next
   fix zs z' Z'
   assume *: "z Z. rho zs z = Some Z  fresh xs x Z" and **: "?rhosw zs z' = Some Z'"
   let ?z = "z' @zs[y1  y2]_ys"
   obtain Z where rho: "rho zs ?z = Some Z" and Z': "Z' = Z #[y1  y2]_ys"
   using ** unfolding swapEnv_defs lift_def by(cases "rho zs ?z", auto)
   hence "fresh xs x Z" using * by simp
   moreover have "good Z" using rho good unfolding goodEnv_def liftAll_def by simp
   ultimately show "fresh xs ?xsw Z'" unfolding Z' using swap_preserves_fresh by auto
 qed
 ultimately show ?thesis unfolding freshEnv_def swapEnv_defs
 unfolding liftAll_def by simp
qed

lemma swapEnv_preserves_freshEnv_distinct:
assumes "goodEnv rho" and
       "xs  ys  x  {y1,y2}"
shows "freshEnv xs x (rho &[y1  y2]_ys) = freshEnv xs x rho"
by (metis assms sw_simps3 swapEnv_preserves_freshEnv)

lemma freshEnv_swapEnv_exchange1:
assumes "goodEnv rho"
shows "freshEnv xs x2 (rho &[x1  x2]_xs) = freshEnv xs x1 rho"
by (metis assms sw_simps1 swapEnv_preserves_freshEnv)

lemma freshEnv_swapEnv_exchange2:
assumes "goodEnv rho"
shows "freshEnv xs x2 (rho &[x2  x1]_xs) = freshEnv xs x1 rho"
using assms by(simp add: freshEnv_swapEnv_exchange1 swapEnv_sym)

lemma freshEnv_swapEnv_id[simp]:
assumes good: "goodEnv rho" and
        fresh: "freshEnv xs x1 rho"  "freshEnv xs x2 rho"
shows "(rho &[x1  x2]_xs) = rho"
proof(intro ext)
  fix us u
  let ?usw = "u @us[x1  x2]_xs" let ?rhosw = "rho &[x1  x2]_xs"
  let ?Sw = "λ X. (X #[x1  x2]_xs)"
  show "?rhosw us u = rho us u"
  proof(cases "rho us u")
    case None
    hence "rho us ?usw = None" using fresh unfolding freshEnv_def sw_def by auto
    hence "?rhosw us u = None" unfolding swapEnv_defs lift_def by auto
    with None show ?thesis by simp
  next
   case (Some X)
   moreover have "?usw = u"  using fresh Some unfolding freshEnv_def sw_def by auto
   ultimately have "?rhosw us u = Some (?Sw X)" unfolding swapEnv_defs lift_def by auto
   moreover
   {have "good X" using Some good unfolding goodEnv_def liftAll_def by auto
    moreover have "fresh xs x1 X" and "fresh xs x2 X"
    using Some fresh unfolding freshEnv_def liftAll_def by auto
    ultimately have "?Sw X = X" by simp
   }
   ultimately show ?thesis using Some by simp
  qed
qed

lemma freshEnv_swapEnv_compose:
assumes good: "goodEnv rho" and
        fresh: "freshEnv xs y rho"  "freshEnv xs z rho"
shows "((rho &[y  x]_xs) &[z  y]_xs) = (rho &[z  x]_xs)"
by (simp add: fresh good sw_def swapEnv_compose)

lemmas good_swapAll_freshAll_otherSimps =
swap_ident swap_involutive swap_involutive2 swap_preserves_fresh fresh_swap_id
freshAbs_swapAbs_id
swapEnv_ident swapEnv_involutive swapEnv_involutive2 swapEnv_preserves_freshEnv freshEnv_swapEnv_id

subsubsection ‹Properties of the relation of being swapped›

theorem swap_swapped: "(X, X #[x  y]_zs)  swapped"
by(auto simp add: swapped.Refl swapped.Swap)

lemma swapped_preserves_good:
assumes "good X" and "(X,Y)  swapped"
shows "good Y"
using assms(2,1) by (induct rule: swapped.induct) auto

lemma swapped_skel:
assumes "good X" and "(X,Y)  swapped"
shows "skel Y = skel X"
using assms(2,1) 
by (induct rule: swapped.induct) (auto simp: swapped_preserves_good skel_swap)

lemma obtain_rep:
assumes GOOD: "good X" and FRESH: "fresh xs x' X"
shows " X'. (X,X')  swapped  good X'  Abs xs x X = Abs xs x' X'"
using Abs_swap_fresh FRESH GOOD swap_preserves_good swap_swapped by blast

subsection ‹Induction›

subsubsection ‹Induction lifted from quasi-terms›

lemma term_templateInduct[case_names rel Var Op Abs]:
fixes X::"('index,'bindex,'varSort,'var,'opSym)term" and
      A::"('index,'bindex,'varSort,'var,'opSym)abs" and phi phiAbs rel
assumes
rel: " X Y. good X; (X,Y)  rel  good Y  skel Y = skel X" and
var: " xs x. phi (Var xs x)" and
op: " delta inp binp. goodInp inp; goodBinp binp; liftAll phi inp; liftAll phiAbs binp
                        phi (Op delta inp binp)" and
abs: " xs x X. good X;  Y. (X,Y)  rel  phi Y
                 phiAbs (Abs xs x X)"
shows "(good X  phi X)  (goodAbs A  phiAbs A)"
proof-
  let ?qX = "pick X"   let ?qA = "pick A"
  let ?qphi = "phi o asTerm"   let ?qphiAbs = "phiAbs o asAbs"
  let ?qrel = "{(qY, qY')| qY qY'. (asTerm qY, asTerm qY')  rel}"
  (*   *)
  have "(good X  qGood ?qX)  (goodAbs A  qGoodAbs ?qA)"
  using good_imp_qGood_pick goodAbs_imp_qGoodAbs_pick by auto
  moreover
  have "(good X  (?qphi ?qX = phi X))  (goodAbs A  (?qphiAbs ?qA = phiAbs A))"
  using asTerm_pick asAbs_pick by fastforce
  moreover
  have "(qGood ?qX  ?qphi ?qX)  (qGoodAbs ?qA  ?qphiAbs ?qA)"
  proof(induction rule: qGood_qTerm_templateInduct[of ?qrel])
    case (Rel qX qY)
    thus ?case using qGood_iff_good_asTerm pick_asTerm unfolding skel_def 
    using rel skel_asTerm_qSkel   
    by simp (smt qGood_iff_good_asTerm skel_asTerm_qSkel)  
  next
    case (Var xs x)
    then show ?case using var unfolding Var_def by simp
  next
    case (Op delta qinp qbinp) 
    hence good_qinp: "qGoodInp qinp  qGoodBinp qbinp"
    unfolding qGoodInp_def qGoodBinp_def liftAll_def by simp
    let ?inp = "asInp qinp"   let ?binp = "asBinp qbinp"
    have good_inp: "goodInp ?inp  goodBinp ?binp"
    using good_qinp qGoodInp_iff_goodInp_asInp qGoodBinp_iff_goodBinp_asBinp by auto
    have 1: "Op delta ?inp ?binp = asTerm (qOp delta qinp qbinp)"
    using good_qinp Op_asInp_asTerm_qOp by fastforce
    {fix i X
     assume inp: "?inp i = Some X"
     then obtain qX where qinp: "qinp i = Some qX" and X: "X = asTerm qX"
     unfolding asInp_def lift_def by(cases "qinp i", auto)
     have "qGood qX  phi (asTerm qX)" using qinp Op.IH by (simp add: liftAll_def)
     hence "good X  phi X" unfolding X using qGood_iff_good_asTerm by auto
    }
    moreover
    {fix i A
     assume binp: "?binp i = Some A"
     then obtain qA where qbinp: "qbinp i = Some qA" and A: "A = asAbs qA"
     unfolding asBinp_def lift_def by(cases "qbinp i", auto)
     have "qGoodAbs qA  phiAbs (asAbs qA)" using qbinp Op.IH by (simp add: liftAll_def)
     hence "goodAbs A  phiAbs A" unfolding A using qGoodAbs_iff_goodAbs_asAbs by auto
    }
    ultimately show ?case
    using op[of ?inp ?binp delta] good_inp unfolding 1 liftAll_def by simp
  next
    case (Abs xs x qX) 
    have "good (asTerm qX)" using ‹qGood qX qGood_iff_good_asTerm by auto
    moreover
    {fix Y   assume *: "(asTerm qX, Y)  rel"
     obtain qY where qY: "qY = pick Y" by blast
     have "good (asTerm qX)" using ‹qGood qX qGood_iff_good_asTerm by auto
     hence "good Y" using * rel by auto 
     hence Y: "Y = asTerm qY" unfolding qY using asTerm_pick by auto
     have "phi Y" using * Abs.IH unfolding Y by simp
    }
    ultimately have "phiAbs (Abs xs x (asTerm qX))" using abs by simp
    thus ?case using ‹qGood qX Abs_asTerm_asAbs_qAbs by fastforce
  qed
  (*  *)
  ultimately show ?thesis by blast
qed

lemma term_rawInduct[case_names Var Op Abs]:
fixes X::"('index,'bindex,'varSort,'var,'opSym)term" and
      A::"('index,'bindex,'varSort,'var,'opSym)abs" and phi phiAbs
assumes
Var: " xs x. phi (Var xs x)" and
Op: " delta inp binp. goodInp inp; goodBinp binp; liftAll phi inp; liftAll phiAbs binp
                        phi (Op delta inp binp)" and
Abs: " xs x X. good X; phi X  phiAbs (Abs xs x X)"
shows "(good X  phi X)  (goodAbs A  phiAbs A)"
by(rule term_templateInduct[of Id], auto simp add: assms)

lemma term_induct[case_names Var Op Abs]:
fixes X::"('index,'bindex,'varSort,'var,'opSym)term" and
      A::"('index,'bindex,'varSort,'var,'opSym)abs" and phi phiAbs
assumes
Var: " xs x. phi (Var xs x)" and
Op: " delta inp binp. goodInp inp; goodBinp binp; liftAll phi inp; liftAll phiAbs binp
                        phi (Op delta inp binp)" and
Abs: " xs x X. good X;
                  Y. (X,Y)  swapped  phi Y;
                  Y. good Y; skel Y = skel X  phi Y
                 phiAbs (Abs xs x X)"
shows "(good X  phi X)  (goodAbs A  phiAbs A)"
apply(induct rule: term_templateInduct[of "swapped  {(X,Y). good Y  skel Y = skel X}"])
by(auto simp: assms swapped_skel swapped_preserves_good) 

subsubsection ‹Fresh induction›

text‹First a general situation, where parameters are of an unspecified type (that should be given by the user):›
 
lemma term_fresh_forall_induct[case_names PAR Var Op Abs]:
fixes X::"('index,'bindex,'varSort,'var,'opSym)term" and A::"('index,'bindex,'varSort,'var,'opSym)abs" 
and phi and phiAbs and varsOf :: "'param  'varSort  'var set" 
assumes
PAR: " p xs. ( |varsOf xs p| <o |UNIV::'var set| )" and
var: " xs x p. phi (Var xs x) p" and
op: " delta inp binp p.  
   |{i. inp i  None}| <o |UNIV::'var set|; |{i. binp i  None}| <o |UNIV::'var set|;
    liftAll (λ X. good X  ( q. phi X p)) inp; liftAll (λ A. goodAbs A  ( q. phiAbs A p)) binp
    phi (Op delta inp binp) p" and
abs: " xs x X p. good X; x  varsOf p xs; phi X p  phiAbs (Abs xs x X) p"
shows "(good X  ( p. phi X p))  (goodAbs A  ( p. phiAbs A p))"
proof(induction rule: term_templateInduct[of swapped])
  case (Abs xs x X)
  show ?case proof safe 
    fix p 
    obtain x' where x'_freshP: "x'  varsOf p xs" and x'_fresh_X: "fresh xs x' X"
    using ‹good X PAR obtain_fresh[of "varsOf p xs" "{X}" "{}" "{}" xs] by auto
    then obtain X' where XX': "(X, X')  swapped" and good_X': "good X'" and
    Abs_eq: "Abs xs x X = Abs xs x' X'"
    using ‹good X x'_freshP x'_fresh_X using obtain_rep[of X xs x' x] by auto
    thus "phiAbs (Abs xs x X) p"
    unfolding Abs_eq using x'_freshP good_X' abs Abs.IH by simp
  qed
qed(insert assms swapped_preserves_good swapped_skel, 
   unfold liftAll_def goodInp_def goodBinp_def, auto)

  
lemma term_templateInduct_fresh[case_names PAR Var Op Abs]:
fixes X::"('index,'bindex,'varSort,'var,'opSym)term" and
      A::"('index,'bindex,'varSort,'var,'opSym)abs" and
      rel and phi and phiAbs and
      vars :: "'varSort  'var set" and
      terms :: "('index,'bindex,'varSort,'var,'opSym)term set" and
      abs :: "('index,'bindex,'varSort,'var,'opSym)abs set" and
      envs :: "('index,'bindex,'varSort,'var,'opSym)env set"
assumes
PAR:
" xs.
   ( |vars xs| <o |UNIV :: 'var set|  finite (vars xs)) 
   ( |terms| <o |UNIV :: 'var set|  finite terms)  ( X  terms. good X) 
   ( |abs| <o |UNIV :: 'var set|  finite abs)  ( A  abs. goodAbs A) 
   ( |envs| <o |UNIV :: 'var set|  finite envs)  ( rho  envs. goodEnv rho)" and
rel: " X Y. good X; (X,Y)  rel  good Y  skel Y = skel X" and
Var: " xs x. phi (Var xs x)" and
Op:
" delta inp binp.
   goodInp inp; goodBinp binp;
    liftAll phi inp; liftAll phiAbs binp
    phi (Op delta inp binp)" and
abs:
" xs x X.
  good X;
   x  vars xs;
    Y. Y  terms  fresh xs x Y;
    A. A  abs  freshAbs xs x A;
    rho. rho  envs  freshEnv xs x rho;
    Y. (X,Y)  rel  phi Y
   phiAbs (Abs xs x X)"
shows
"(good X  phi X) 
 (goodAbs A  phiAbs A)"
proof(induction rule: term_templateInduct[of "swapped O rel"])
  case (Abs xs x X) note good_X = ‹good X  
  have "|{X}  terms| <o |UNIV :: 'var set|  finite ({X}  terms)"
  apply(cases "finite terms", auto simp add: PAR)
  using PAR var_infinite_INNER card_of_Un_singl_ordLess_infinite by force
  then obtain x' where x'_not: "x'  vars xs" and
  x'_fresh_X: "fresh xs x' X" and
  x'_freshP: "( Y  terms. fresh xs x' Y) 
              ( A  abs. freshAbs xs x' A) 
              ( rho  envs. freshEnv xs x' rho)"
  using good_X PAR
  using obtain_fresh[of "vars xs" "{X}  terms" abs envs xs] by auto
  then obtain X' where XX': "(X, X')  swapped" and good_X': "good X'" and
  Abs_eq: "Abs xs x X = Abs xs x' X'"
  using good_X x'_not x'_fresh_X using obtain_rep[of X xs x' x] by auto
  have "Y. (X', Y)  rel  phi Y" using XX' Abs.IH by auto 
  thus ?case
  unfolding Abs_eq using x'_not x'_freshP good_X' abs by auto
qed(insert Op rel, unfold relcomp_unfold liftAll_def, simp_all add: Var, 
     metis rel swapped_preserves_good swapped_skel) 

text‹A version of the above not employing any relation for the bound-argument case:›

lemma term_rawInduct_fresh[case_names Par Var Op Obs]:
fixes X::"('index,'bindex,'varSort,'var,'opSym)term" and
      A::"('index,'bindex,'varSort,'var,'opSym)abs" and
      vars :: "'varSort  'var set" and
      terms :: "('index,'bindex,'varSort,'var,'opSym)term set" and
      abs :: "('index,'bindex,'varSort,'var,'opSym)abs set" and
      envs :: "('index,'bindex,'varSort,'var,'opSym)env set"
assumes
PAR:
" xs.
   ( |vars xs| <o |UNIV :: 'var set|  finite (vars xs)) 
   ( |terms| <o |UNIV :: 'var set|  finite terms)  ( X  terms. good X) 
   ( |abs| <o |UNIV :: 'var set|  finite abs)  ( A  abs. goodAbs A) 
   ( |envs| <o |UNIV :: 'var set|  finite envs)  ( rho  envs. goodEnv rho)" and
Var: " xs x. phi (Var xs x)" and
Op:
" delta inp binp.
   goodInp inp; goodBinp binp;
    liftAll phi inp; liftAll phiAbs binp
    phi (Op delta inp binp)" and
Abs:
" xs x X.
  good X;
   x  vars xs;
    Y. Y  terms  fresh xs x Y;
    A. A  abs  freshAbs xs x A;
    rho. rho  envs  freshEnv xs x rho;
   phi X
   phiAbs (Abs xs x X)"
shows
"(good X  phi X) 
 (goodAbs A  phiAbs A)"
apply(induct rule: term_templateInduct_fresh[of vars terms abs envs Id])
using assms by auto

(* Note that here, since we avoid variable-capture and hence will
 not typically need to swap, term-inductRaw_fresh will suffice in proofs.
 Therefore we do not prove a swapped-and-skel version of fresh induction, although such a version
 could be easily inferred from ``term-templateInduct". *)

text‹The typical raw induction with freshness is one dealing with
   finitely many variables, terms, abstractions and environments as parameters --
   we have all these condensed in the notion of a parameter (type
   constructor ``param"):›

lemma term_induct_fresh[case_names Par Var Op Abs]:
fixes X :: "('index,'bindex,'varSort,'var,'opSym)term" and
      A :: "('index,'bindex,'varSort,'var,'opSym)abs" and
      P :: "('index,'bindex,'varSort,'var,'opSym)param"
assumes
goodP: "goodPar P" and
Var: " xs x. phi (Var xs x)" and
Op:
" delta inp binp.
   goodInp inp; goodBinp binp;
    liftAll phi inp; liftAll phiAbs binp
    phi (Op delta inp binp)" and
Abs:
" xs x X.
   good X;
    x  varsOf P;
     Y. Y  termsOf P  fresh xs x Y;
     A. A  absOf P  freshAbs xs x A;
     rho. rho  envsOf P  freshEnv xs x rho;
    phi X
    phiAbs (Abs xs x X)"
shows
"(good X  phi X) 
 (goodAbs A  phiAbs A)"
proof(induct rule: term_rawInduct_fresh
      [of "λ xs. varsOf P" "termsOf P" "absOf P" "envsOf P"])
  case (Par xs)
  then show ?case unfolding goodPar_def  
  using goodP by(cases P) simp
qed(insert assms, auto) 

end  (* context FixVars  *)

end

Theory Terms

section ‹More on Terms›

theory Terms imports Transition_QuasiTerms_Terms
begin

text‹In this section, we continue the study of terms, with stating and proving
properties specific to terms (while in the previous section we dealt with
lifting properties from quasi-terms).
Consequently, in this theory, not only the theorems, but neither the proofs
should mention quasi-items at all.
Among the properties specific to terms will
be the compositionality properties of substitution (while, by contrast, similar properties
of swapping also held for quasi-tems).
›

context FixVars (* scope all throughout the file *)
begin

declare qItem_simps[simp del]
declare qItem_versus_item_simps[simp del]

subsection ‹Identity environment versus other operators›

(* Recall theorem getEnv_idEnv. *)

theorem getEnv_updEnv_idEnv[simp]:
"(idEnv [x  X]_xs) ys y = (if (ys = xs  y = x) then Some X else None)"
unfolding idEnv_def updEnv_def by simp

theorem subst_psubst_idEnv:
"(X #[Y / y]_ys) = (X #[idEnv [y  Y]_ys])"
unfolding subst_def idEnv_def updEnv_def psubst_def by simp

theorem vsubst_psubst_idEnv:
"(X #[z // y]_ys) = (X #[idEnv [y  Var ys z]_ys])"
unfolding vsubst_def by(simp add: subst_psubst_idEnv)

theorem substEnv_psubstEnv_idEnv:
"(rho &[Y / y]_ys) = (rho &[idEnv [y  Y]_ys])"
unfolding substEnv_def idEnv_def updEnv_def psubstEnv_def by simp

theorem vsubstEnv_psubstEnv_idEnv:
"(rho &[z // y]_ys) = (rho &[idEnv [y  Var ys z]_ys])"
unfolding vsubstEnv_def by (simp add: substEnv_psubstEnv_idEnv)

theorem freshEnv_idEnv: "freshEnv xs x idEnv"
unfolding idEnv_def freshEnv_def liftAll_def by simp

theorem swapEnv_idEnv[simp]: "(idEnv &[x  y]_xs) = idEnv"
unfolding idEnv_def swapEnv_def comp_def swapEnvDom_def swapEnvIm_def lift_def by simp

theorem psubstEnv_idEnv[simp]: "(idEnv &[rho]) = rho"
unfolding idEnv_def psubstEnv_def lift_def by simp

theorem substEnv_idEnv: "(idEnv &[X / x]_xs) = (idEnv [x  X]_xs)"
unfolding substEnv_def using psubstEnv_idEnv by auto

theorem vsubstEnv_idEnv: "(idEnv &[y // x]_xs) = (idEnv [x  (Var xs y)]_xs)"
unfolding vsubstEnv_def using substEnv_idEnv .

lemma psubstAll_idEnv:
fixes X::"('index,'bindex,'varSort,'var,'opSym)term" and
      A::"('index,'bindex,'varSort,'var,'opSym)abs"
shows
"(good X   (X #[idEnv]) = X) 
 (goodAbs A   (A $[idEnv]) = A)"
apply(induct rule: term_rawInduct)   
unfolding psubstInp_def psubstBinp_def
using idEnv_preserves_good psubst_Var_simp1
by (simp_all del: getEnv_idEnv add: 
liftAll_lift_ext lift_ident freshEnv_idEnv psubstBinp_def psubstInp_def)
  fastforce+  

lemma psubst_idEnv[simp]:
"good X  (X #[idEnv]) = X"
by(simp add: psubstAll_idEnv)

lemma psubstEnv_idEnv_id[simp]:
assumes "goodEnv rho"
shows "(rho &[idEnv]) = rho"
using assms unfolding psubstEnv_def lift_def goodEnv_def liftAll_def  
apply(intro ext) subgoal for xs x by(cases "rho xs x") auto .

subsection ‹Environment update versus other operators›

(* Recall theorem getEnv_updEnv. *)

theorem updEnv_overwrite[simp]: "((rho [x  X]_xs) [x  X']_xs) = (rho [x  X']_xs)"
unfolding updEnv_def by fastforce

theorem updEnv_commute:
assumes "xs  ys  x  y"
shows "((rho [x  X]_xs) [y  Y]_ys) = ((rho [y  Y]_ys) [x  X]_xs)"
using assms unfolding updEnv_def by fastforce

theorem freshEnv_updEnv_E1:
assumes "freshEnv xs y (rho [x  X]_xs)"
shows "y  x"
using assms unfolding freshEnv_def liftAll_def updEnv_def by auto

theorem freshEnv_updEnv_E2:
assumes "freshEnv ys y (rho [x  X]_xs)"
shows "fresh ys y X"
using assms unfolding freshEnv_def liftAll_def updEnv_def 
by (auto split: if_splits) 

theorem freshEnv_updEnv_E3:
assumes "freshEnv ys y (rho [x  X]_xs)"
shows "rho ys y = None"
using assms freshEnv_updEnv_E1[of ys y] unfolding freshEnv_def
by (metis getEnv_updEnv option.simps(3)) 

theorem freshEnv_updEnv_E4:
assumes "freshEnv ys y (rho [x  X]_xs)"
and "zs  xs  z  x" and "rho zs z = Some Z"
shows "fresh ys y Z"
using assms unfolding freshEnv_def liftAll_def 
by (metis getEnv_updEnv1)

theorem freshEnv_updEnv_I:
assumes "ys  xs  y  x" and "fresh ys y X" and "rho ys y = None"
and " zs z Z. zs  xs  z  x; rho zs z = Some Z  fresh ys y Z"
shows "freshEnv ys y (rho [x  X]_xs)"
unfolding freshEnv_def liftAll_def
using assms by auto 

theorem swapEnv_updEnv:
"((rho [x  X]_xs) &[y1  y2]_ys) =
 ((rho &[y1  y2]_ys) [(x @xs[y1  y2]_ys)  (X #[y1  y2]_ys)]_xs)"
unfolding swapEnv_defs sw_def lift_def
by(cases "xs = ys") fastforce+

lemma swapEnv_updEnv_fresh:
assumes "ys  xs  x  {y1,y2}" and "good X"
and "fresh ys y1 X" and "fresh ys y2 X"
shows "((rho [x  X]_xs) &[y1  y2]_ys) =
       ((rho &[y1  y2]_ys) [x  X]_xs)"
using assms by(simp add: swapEnv_updEnv)

theorem psubstEnv_updEnv:
"((rho [x  X]_xs) &[rho']) = ((rho &[rho']) [x  (X #[rho'])]_xs)"
unfolding psubstEnv_def by fastforce

theorem psubstEnv_updEnv_idEnv:
"((idEnv [x  X]_xs) &[rho]) = (rho [x  (X #[rho])]_xs)"
by(simp add: psubstEnv_updEnv)

theorem substEnv_updEnv:
"((rho [x  X]_xs) &[Y / y]_ys) = ((rho &[Y / y]_ys) [x  (X #[Y / y]_ys)]_xs)"
unfolding substEnv_def subst_def by(rule psubstEnv_updEnv)

theorem vsubstEnv_updEnv:
"((rho [x  X]_xs) &[y1 // y]_ys) = ((rho &[y1 // y]_ys) [x  (X #[y1 // y]_ys)]_xs)"
unfolding vsubstEnv_def vsubst_def using substEnv_updEnv .

subsection ‹Environment ``get" versus other operators›

text‹Currently, ``get" is just function application.  While the next
properties are immediate consequences of the definitions, it is worth stating
them because of their abstract character (since later, concrete terms
inferred from abstract terms by a presumptive package, ``get" will no longer
be function application).›

theorem getEnv_ext:
assumes " xs x. rho xs x = rho' xs x"
shows "rho = rho'"
using assms by(simp add: ext)

theorem freshEnv_getEnv1[simp]:
"freshEnv ys y rho; rho xs x = Some X  ys  xs  y  x"
unfolding freshEnv_def by auto

theorem freshEnv_getEnv2[simp]:
"freshEnv ys y rho; rho xs x = Some X  fresh ys y X"
unfolding freshEnv_def liftAll_def by simp

theorem freshEnv_getEnv[simp]:
"freshEnv ys y rho  rho ys y = None"
unfolding freshEnv_def by simp

theorem getEnv_swapEnv1[simp]:
assumes "rho xs (x @xs [z1  z2]_zs) = None"
shows "(rho &[z1  z2]_zs) xs x = None"
using assms unfolding swapEnv_defs lift_def by simp

theorem getEnv_swapEnv2[simp]:
assumes "rho xs (x @xs [z1  z2]_zs) = Some X"
shows "(rho &[z1  z2]_zs) xs x = Some (X #[z1  z2]_zs)"
using assms unfolding swapEnv_defs lift_def by simp

theorem getEnv_psubstEnv_None[simp]:
assumes "rho xs x = None"
shows "(rho &[rho']) xs x = rho' xs x"
using assms unfolding psubstEnv_def by simp

theorem getEnv_psubstEnv_Some[simp]:
assumes "rho xs x = Some X"
shows "(rho &[rho']) xs x = Some (X #[rho'])"
using assms unfolding psubstEnv_def by simp

theorem getEnv_substEnv1[simp]:
assumes "ys  xs  y  x" and "rho xs x = None"
shows "(rho &[Y / y]_ys) xs x = None"
using assms unfolding substEnv_def2 by auto

theorem getEnv_substEnv2[simp]:
assumes "ys  xs  y  x" and "rho xs x = Some X"
shows "(rho &[Y / y]_ys) xs x = Some (X #[Y / y]_ys)"
using assms unfolding substEnv_def2 by auto

theorem getEnv_substEnv3[simp]:
"ys  xs  y  x; freshEnv xs x rho
  (rho &[Y / y]_ys) xs x = None"
using getEnv_substEnv1 by auto

theorem getEnv_substEnv4[simp]:
"freshEnv ys y rho  (rho &[Y / y]_ys) ys y = Some Y"
unfolding substEnv_psubstEnv_idEnv by simp

theorem getEnv_vsubstEnv1[simp]:
assumes "ys  xs  y  x" and "rho xs x = None"
shows "(rho &[y1 // y]_ys) xs x = None"
using assms unfolding vsubstEnv_def by auto

theorem getEnv_vsubstEnv2[simp]:
assumes "ys  xs  y  x" and "rho xs x = Some X"
shows "(rho &[y1 // y]_ys) xs x = Some (X #[y1 // y]_ys)"
using assms unfolding vsubstEnv_def vsubst_def by auto

theorem getEnv_vsubstEnv3[simp]:
"ys  xs  y  x; freshEnv xs x rho
  (rho &[z // y]_ys) xs x = None"
using getEnv_vsubstEnv1 by auto

theorem getEnv_vsubstEnv4[simp]:
"freshEnv ys y rho  (rho &[z // y]_ys) ys y = Some (Var ys z)"
unfolding vsubstEnv_psubstEnv_idEnv by simp

subsection ‹Substitution versus other operators›

definition freshImEnvAt ::
"'varSort  'var  ('index,'bindex,'varSort,'var,'opSym)env  'varSort  'var  bool"
where
"freshImEnvAt xs x rho ys y ==
 rho ys y = None  (ys  xs  y  x) 
 ( Y. rho ys y = Some Y  fresh xs x Y)"

lemma freshAll_psubstAll:
fixes X::"('index,'bindex,'varSort,'var,'opSym)term" and
      A::"('index,'bindex,'varSort,'var,'opSym)abs" and
      P::"('index,'bindex,'varSort,'var,'opSym)param" and x
assumes goodP: "goodPar P"
shows
"(good X  z  varsOf P 
  ( rho  envsOf P.
     fresh zs z (X #[rho]) =
     ( ys.  y. fresh ys y X  freshImEnvAt zs z rho ys y)))
 
 (goodAbs A  z  varsOf P 
  ( rho  envsOf P.
     freshAbs zs z (A $[rho]) =
     ( ys.  y. freshAbs ys y A  freshImEnvAt zs z rho ys y)))"
proof(induction rule: term_induct_fresh[of P])
  case Par
  then show ?case using goodP by simp
next
  case (Var ys y)
  thus ?case proof clarify 
    fix rho
    assume r: "rho  envsOf P"
    hence g: "goodEnv rho" using goodP by simp    
    thus "fresh zs z (psubst rho (Var ys y)) = 
     (ysa ya. fresh ysa ya (Var ys y)  freshImEnvAt zs z rho ysa ya)" 
    unfolding freshImEnvAt_def
    by(cases "ys = zs  y = z", (cases "rho ys y", auto)+)
  qed
next
  case (Op delta inp binp)
  show ?case proof clarify 
    fix rho 
    assume P: "z  varsOf P" "rho  envsOf P"
    let ?L1 = "liftAll (fresh zs z  psubst rho) inp"
    let ?L2 = "liftAll (freshAbs zs z  psubstAbs rho) binp"
    let ?R1 = "%ys y. liftAll (fresh ys y) inp"
    let ?R2 = "%ys y. liftAll (freshAbs ys y) binp"
    let ?R3 = "%ys y. freshImEnvAt zs z rho ys y"
    have "(?L1  ?L2) = (ys y. ?R1 ys y  ?R2 ys y  ?R3 ys y)"
    using Op.IH P unfolding liftAll_def by simp blast
    thus "fresh zs z ((Op delta inp binp) #[rho]) =
           (ys y. fresh ys y (Op delta inp binp)  freshImEnvAt zs z rho ys y)" 
    by (metis (no_types, lifting) Op.hyps(1) Op.hyps(2) P(2) envsOf_preserves_good freshBinp_def freshInp_def fresh_Op_simp goodP liftAll_lift_comp psubstBinp_def psubstBinp_preserves_good 
     psubstInp_def psubstInp_preserves_good psubst_Op_simp)
  qed
next
  case (Abs xs x X)  
  thus ?case  
  using goodP by simp (metis (full_types) freshEnv_def freshImEnvAt_def)
qed 

corollary fresh_psubst:
assumes "good X" and "goodEnv rho"
shows
"fresh zs z (X #[rho]) =
 ( ys y. fresh ys y X  freshImEnvAt zs z rho ys y)"
using assms freshAll_psubstAll[of "Par [z] [] [] [rho]"]
unfolding goodPar_def by simp

corollary fresh_psubst_E1:
assumes "good X" and "goodEnv rho"
and "rho ys y = None" and "fresh zs z (X #[rho])"
shows "fresh ys y X  (ys  zs  y  z)"
using assms fresh_psubst unfolding freshImEnvAt_def by fastforce

corollary fresh_psubst_E2:
assumes "good X" and "goodEnv rho"
and "rho ys y = Some Y" and "fresh zs z (X #[rho])"
shows "fresh ys y X  fresh zs z Y"
using assms fresh_psubst[of X rho] unfolding freshImEnvAt_def by fastforce

corollary fresh_psubst_I1:
assumes "good X" and "goodEnv rho"
and "fresh zs z X" and "freshEnv zs z rho"
shows "fresh zs z (X #[rho])"
using assms apply(simp add: fresh_psubst)
unfolding freshEnv_def liftAll_def freshImEnvAt_def by auto

corollary psubstEnv_preserves_freshEnv:
assumes good: "goodEnv rho"  "goodEnv rho'"
and fresh: "freshEnv zs z rho"  "freshEnv zs z rho'"
shows "freshEnv zs z (rho &[rho'])"
using assms unfolding freshEnv_def liftAll_def  
by simp (smt Var_preserves_good fresh(2) fresh_psubst_I1 option.case_eq_if 
option.exhaust_sel option.sel psubstEnv_def psubst_Var_simp2 psubst_preserves_good)

corollary fresh_psubst_I:
assumes "good X" and "goodEnv rho"
and "rho zs z = None  fresh zs z X" and
    " ys y Y. rho ys y = Some Y  fresh ys y X  fresh zs z Y"
shows "fresh zs z (X #[rho])"
using assms unfolding freshImEnvAt_def 
by (simp add: fresh_psubst) (metis freshImEnvAt_def not_None_eq)

lemma fresh_subst:
assumes "good X" and "good Y"
shows "fresh zs z (X #[Y / y]_ys) =
       (((zs = ys  z = y)  fresh zs z X)  (fresh ys y X  fresh zs z Y))"
using assms unfolding subst_def freshImEnvAt_def 
by (simp add: fresh_psubst) 
(metis (no_types, lifting) freshImEnvAt_def fresh_psubst fresh_psubst_E2 
getEnv_updEnv_idEnv idEnv_preserves_good option.simps(3) updEnv_preserves_good)

lemma fresh_vsubst:
assumes "good X"
shows "fresh zs z (X #[y1 // y]_ys) =
       (((zs = ys  z = y)  fresh zs z X)  (fresh ys y X  (zs  ys  z  y1)))"
unfolding vsubst_def using assms by(auto simp: fresh_subst)

lemma subst_preserves_fresh:
assumes "good X" and "good Y"
and "fresh zs z X" and "fresh zs z Y"
shows "fresh zs z (X #[Y / y]_ys)"
using assms by(simp add: fresh_subst)

lemma substEnv_preserves_freshEnv_aux:
assumes rho: "goodEnv rho" and Y: "good Y"
and fresh_rho: "freshEnv zs z rho" and fresh_Y: "fresh zs z Y" and diff: "zs  ys  z  y"
shows "freshEnv zs z (rho &[Y / y]_ys)"
using assms unfolding freshEnv_def liftAll_def 
by (simp add: option.case_eq_if substEnv_def2 subst_preserves_fresh)

lemma substEnv_preserves_freshEnv:
assumes rho: "goodEnv rho" and Y: "good Y"
and fresh_rho: "freshEnv zs z rho" and fresh_Y: "fresh zs z Y" and diff: "zs  ys  z  y"
shows "freshEnv zs z (rho &[Y / y]_ys)"
using assms by(simp add: substEnv_preserves_freshEnv_aux)

lemma vsubst_preserves_fresh:
assumes "good X"
and "fresh zs z X" and "zs  ys  z  y1"
shows "fresh zs z (X #[y1 // y]_ys)"
using assms by(simp add: fresh_vsubst)

lemma vsubstEnv_preserves_freshEnv:
assumes rho: "goodEnv rho"
and fresh_rho: "freshEnv zs z rho" and diff: "zs  ys  z  {y,y1}"
shows "freshEnv zs z (rho &[y1 // y]_ys)"
using assms unfolding vsubstEnv_def
by(simp add: substEnv_preserves_freshEnv)

lemma fresh_fresh_subst[simp]:
assumes "good Y" and "good X"
and "fresh ys y Y"
shows "fresh ys y (X #[Y / y]_ys)"
using assms by(simp add: fresh_subst)

lemma diff_fresh_vsubst[simp]:
assumes "good X"
and "y  y1"
shows "fresh ys y (X #[y1 // y]_ys)"
using assms by(simp add: fresh_vsubst)

lemma fresh_subst_E1:
assumes "good X" and "good Y"
and "fresh zs z (X #[Y / y]_ys)" and "zs  ys  z  y"
shows "fresh zs z X"
using assms by(auto simp add: fresh_subst)

lemma fresh_vsubst_E1:
assumes "good X"
and "fresh zs z (X #[y1 // y]_ys)" and "zs  ys  z  y"
shows "fresh zs z X"
using assms by(auto simp add: fresh_vsubst)

lemma fresh_subst_E2:
assumes "good X" and "good Y"
and "fresh zs z (X #[Y / y]_ys)"
shows "fresh ys y X  fresh zs z Y"
using assms by(simp add: fresh_subst)

lemma fresh_vsubst_E2:
assumes "good X"
and "fresh zs z (X #[y1 // y]_ys)"
shows "fresh ys y X  zs  ys  z  y1"
using assms by(simp add: fresh_vsubst)

lemma psubstAll_cong:
fixes X::"('index,'bindex,'varSort,'var,'opSym)term" and
      A::"('index,'bindex,'varSort,'var,'opSym)abs" and
      P::"('index,'bindex,'varSort,'var,'opSym)param"
assumes goodP: "goodPar P"
shows
"(good X 
  ( rho rho'. {rho, rho'}  envsOf P 
   ( ys.  y. fresh ys y X  rho ys y = rho' ys y) 
               (X #[rho]) = (X #[rho'])))

 (goodAbs A 
  ( rho rho'. {rho, rho'}  envsOf P 
   ( ys.  y. freshAbs ys y A  rho ys y = rho' ys y) 
               (A $[rho]) = (A $[rho'])))"
proof(induction rule: term_induct_fresh[of P])
  case Par
  then show ?case using assms .
next  
  case (Var xs x)
  then show ?case using goodP by (auto simp: psubst_Var)
next
  case (Op delta inp binp)
  show ?case proof clarify
    fix rho rho'  
    assume envs: "{rho, rho'}  envsOf P"   
    hence goodEnv: "goodEnv rho  goodEnv rho'" using goodP by simp
    assume "ys y. fresh ys y (Op delta inp binp)  rho ys y = rho' ys y"
    hence 1: "liftAll (λ X. ys y. fresh ys y X  rho ys y = rho' ys y) inp 
            liftAll (λ A. ys y. freshAbs ys y A  rho ys y = rho' ys y) binp"
    using Op by simp (smt freshBinp_def freshInp_def liftAll_def)
    have "liftAll (λ X. (X #[rho]) = (X #[rho'])) inp 
          liftAll (λ A. (A $[rho]) = (A $[rho'])) binp" 
    using Op.IH 1 envs by (auto simp: liftAll_def)
    thus "(Op delta inp binp) #[rho] = (Op delta inp binp) #[rho']" 
    using Op.IH 1
    by (simp add: Op.hyps goodEnv psubstBinp_def psubstInp_def liftAll_lift_ext)
  qed
next
  case (Abs xs x X)
  thus ?case
  using Abs goodP unfolding freshEnv_def liftAll_def 
  by simp (metis Abs.hyps(5) envsOf_preserves_good psubstAbs_simp)
qed

corollary psubst_cong[fundef_cong]:
assumes "good X" and "goodEnv rho" and "goodEnv rho'"
and " ys y. fresh ys y X  rho ys y = rho' ys y"
shows "(X #[rho]) = (X #[rho'])"
using assms psubstAll_cong[of "Par [] [] [] [rho,rho']"]
unfolding goodPar_def by simp

(* Note: A congruence principle for ``psubstEnv" would not hold w.r.t. ``freshEnv",
and the one that would hold w.r.t. ``fresh" would be a mere rephrasing of the
definition of ``psubstEnv", not worth stating. *)

lemma fresh_psubst_updEnv:
assumes "good X" and "good Y" and "goodEnv rho"
and "fresh xs x Y"
shows "(Y #[rho [x  X]_xs]) = (Y #[rho])"
using assms by (auto cong: psubst_cong)

lemma psubstAll_ident:
fixes X :: "('index,'bindex,'varSort,'var,'opSym)term" and
      A :: "('index,'bindex,'varSort,'var,'opSym)abs" and
      P :: "('index,'bindex,'varSort,'var,'opSym) Transition_QuasiTerms_Terms.param"
assumes P: "goodPar P"
shows
"(good X 
  ( rho  envsOf P.
   ( zs z. freshEnv zs z rho  fresh zs z X)
    (X #[rho]) = X))
 
 (goodAbs A 
  ( rho  envsOf P.
   ( zs z. freshEnv zs z rho  freshAbs zs z A)
    (A $[rho]) = A))"
proof(induction rule: term_induct_fresh)
  case (Var xs x)
  then show ?case  
  by (meson assms freshEnv_def fresh_Var_simp goodPar_def psubst_Var_simp1)
next
  case (Op delta inp binp)
  then show ?case  
  by (metis (no_types,lifting) Op_preserves_good assms envsOf_preserves_good 
   freshEnv_getEnv idEnv_def idEnv_preserves_good psubst_cong psubst_idEnv)
qed(insert P, fastforce+)

corollary freshEnv_psubst_ident[simp]:
fixes X :: "('index,'bindex,'varSort,'var,'opSym)term"
assumes "good X" and "goodEnv rho"
and " zs z. freshEnv zs z rho  fresh zs z X"
shows "(X #[rho]) = X"
using assms psubstAll_ident[of "Par [] [] [] [rho]"]
unfolding goodPar_def by simp

lemma fresh_subst_ident[simp]:
assumes "good X" and "good Y" and "fresh xs x Y"
shows "(Y #[X / x]_xs) = Y"
by (simp add: assms fresh_psubst_updEnv subst_def)

corollary substEnv_updEnv_fresh:
assumes "good X" and "good Y" and "fresh ys y X"
shows "((rho [x  X]_xs) &[Y / y]_ys) = ((rho &[Y / y]_ys) [x  X]_xs)"
using assms by(simp add: substEnv_updEnv)

lemma fresh_substEnv_updEnv[simp]:
assumes rho: "goodEnv rho" and Y: "good Y"
and *: "freshEnv ys y rho"
shows "(rho &[Y / y]_ys) = (rho [y  Y]_ys)"
apply (rule getEnv_ext) 
subgoal for xs x using assms by (cases "rho xs x") auto .

lemma fresh_vsubst_ident[simp]:
assumes "good Y" and "fresh xs x Y"
shows "(Y #[x1 // x]_xs) = Y"
using assms unfolding vsubst_def by simp

corollary vsubstEnv_updEnv_fresh:
assumes "good X" and "fresh ys y X"
shows "((rho [x  X]_xs) &[y1 // y]_ys) = ((rho &[y1 // y]_ys) [x  X]_xs)"
using assms by(simp add: vsubstEnv_updEnv)

lemma fresh_vsubstEnv_updEnv[simp]:
assumes rho: "goodEnv rho"
and *: "freshEnv ys y rho"
shows "(rho &[y1 // y]_ys) = (rho [y  Var ys y1]_ys)"
using assms unfolding vsubstEnv_def by simp

lemma swapAll_psubstAll:
fixes X::"('index,'bindex,'varSort,'var,'opSym)term" and
      A::"('index,'bindex,'varSort,'var,'opSym)abs" and
      P::"('index,'bindex,'varSort,'var,'opSym)param"
assumes P: "goodPar P"
shows
"(good X 
  ( rho z1 z2. rho  envsOf P  {z1,z2}  varsOf P 
                ((X #[rho]) #[z1  z2]_zs) = ((X #[z1  z2]_zs) #[rho &[z1  z2]_zs])))
 
 (goodAbs A 
  ( rho z1 z2. rho  envsOf P  {z1,z2}  varsOf P 
                ((A $[rho]) $[z1  z2]_zs) = ((A $[z1  z2]_zs) $[rho &[z1  z2]_zs])))"
proof(induction rule: term_induct_fresh[of P])
  case (Var xs x)
  then show ?case using assms 
  by simp (smt Var_preserves_good envsOf_preserves_good getEnv_swapEnv1 getEnv_swapEnv2 option.case_eq_if option.exhaust_sel psubst_Var psubst_Var_simp2 swapEnv_preserves_good 
 swap_Var_simp swap_involutive2 swap_sym)
next
  case (Op delta inp binp)
  then show ?case 
  using assms  
  unfolding psubstInp_def swapInp_def psubstBinp_def swapBinp_def lift_comp
  unfolding liftAll_def lift_def  
  by simp (auto simp: lift_def psubstInp_def swapInp_def 
  psubstBinp_def swapBinp_def split: option.splits) 
qed(insert assms, auto)
 
lemma swap_psubst:
assumes "good X" and "goodEnv rho"
shows "((X #[rho]) #[z1  z2]_zs) = ((X #[z1  z2]_zs) #[rho &[z1  z2]_zs])"
using assms swapAll_psubstAll[of "Par [z1,z2] [] [] [rho]"]
unfolding goodPar_def by auto

lemma swap_subst:
assumes "good X" and "good Y"
shows "((X #[Y / y]_ys) #[z1  z2]_zs) =
       ((X #[z1  z2]_zs) #[(Y #[z1  z2]_zs) / (y @ys[z1  z2]_zs)]_ys)"
proof-
  have 1: "(idEnv [(y @ys[z1  z2]_zs)  (Y #[z1  z2]_zs)]_ys) =
           ((idEnv [y  Y]_ys) &[z1  z2]_zs)"
  by(simp add: swapEnv_updEnv)
  show ?thesis
  using assms unfolding subst_def 1 by (intro swap_psubst) auto
qed

lemma swap_vsubst:
assumes "good X"
shows "((X #[y1 // y]_ys) #[z1  z2]_zs) =
       ((X #[z1  z2]_zs) #[(y1 @ys[z1  z2]_zs) // (y @ys[z1  z2]_zs)]_ys)"
using assms unfolding vsubst_def
by(simp add: swap_subst)

lemma swapEnv_psubstEnv:
assumes "goodEnv rho" and "goodEnv rho'"
shows "((rho &[rho']) &[z1  z2]_zs) = ((rho &[z1  z2]_zs) &[rho' &[z1  z2]_zs])"  
using assms apply(intro ext)
subgoal for xs x
by (cases "rho xs (x @xs[z1  z2]_zs)")
   (auto simp: lift_def swapEnv_defs swap_psubst) .

lemma swapEnv_substEnv:
assumes "good Y" and "goodEnv rho"
shows "((rho &[Y / y]_ys) &[z1  z2]_zs) =
       ((rho &[z1  z2]_zs) &[(Y #[z1  z2]_zs) / (y @ys[z1  z2]_zs)]_ys)"
proof-
  have 1: "(idEnv [(y @ys[z1  z2]_zs)  (Y #[z1  z2]_zs)]_ys) =
           ((idEnv [y  Y]_ys) &[z1  z2]_zs)"
  by(simp add: swapEnv_updEnv)
  show ?thesis
  unfolding substEnv_def 1 
  using assms by (intro swapEnv_psubstEnv) auto
qed

lemma swapEnv_vsubstEnv:
assumes "goodEnv rho"
shows "((rho &[y1 // y]_ys) &[z1  z2]_zs) =
       ((rho &[z1  z2]_zs) &[(y1 @ys[z1  z2]_zs) // (y @ys[z1  z2]_zs)]_ys)"
using assms unfolding vsubstEnv_def by(simp add: swapEnv_substEnv)

lemma psubstAll_compose:
fixes X::"('index,'bindex,'varSort,'var,'opSym)term" and
      A::"('index,'bindex,'varSort,'var,'opSym)abs" and
      P::"('index,'bindex,'varSort,'var,'opSym)param"
assumes P: "goodPar P"
shows
"(good X 
  ( rho rho'. {rho,rho'}  envsOf P  ((X #[rho]) #[rho']) = (X #[(rho &[rho'])])))

 (goodAbs A 
  ( rho rho'. {rho,rho'}  envsOf P  ((A $[rho]) $[rho']) = (A $[(rho &[rho'])])))"
proof(induction rule: term_induct_fresh[of P])
  case (Var xs x)
  then show ?case using assms 
  by simp (smt envsOf_preserves_good option.case_eq_if option.sel psubstEnv_def 
  psubstEnv_idEnv_id psubstEnv_preserves_good psubst_Var_simp1 psubst_Var_simp2)
next
  case (Op delta inp binp)
  then show ?case 
  using assms  
  unfolding psubstInp_def swapInp_def psubstBinp_def swapBinp_def lift_comp
  unfolding liftAll_def lift_def  
  by simp (auto simp: lift_def psubstInp_def swapInp_def 
  psubstBinp_def swapBinp_def split: option.splits) 
qed(insert assms, simp_all add: psubstEnv_preserves_freshEnv)

corollary psubst_compose:
assumes "good X" and "goodEnv rho" and "goodEnv rho'"
shows "((X #[rho]) #[rho']) = (X #[(rho &[rho'])])"
using assms psubstAll_compose[of "Par [] [] [] [rho, rho']"]
unfolding goodPar_def by auto

lemma psubstEnv_compose:
assumes "goodEnv rho" and "goodEnv rho'" and "goodEnv rho''"
shows "((rho &[rho']) &[rho'']) = (rho &[(rho' &[rho''])])"
using assms apply(intro ext)
subgoal for xs x
by (cases "rho xs x") (auto simp: lift_def psubstEnv_def  psubst_compose) . 
 
lemma psubst_subst_compose:
assumes "good X" and "good Y" and "goodEnv rho"
shows "((X #[Y / y]_ys) #[rho]) = (X #[(rho [y  (Y #[rho])]_ys)])"
by (simp add: assms psubstEnv_updEnv_idEnv psubst_compose subst_psubst_idEnv)

lemma psubstEnv_substEnv_compose:
assumes "goodEnv rho" and "good Y" and "goodEnv rho'"
shows "((rho &[Y / y]_ys) &[rho']) = (rho &[(rho' [y  (Y #[rho'])]_ys)])"
by (simp add: assms psubstEnv_compose psubstEnv_updEnv_idEnv substEnv_def)

lemma psubst_vsubst_compose:
assumes "good X" and "goodEnv rho"
shows "((X #[y1 // y]_ys) #[rho]) = (X #[(rho [y  ((Var ys y1) #[rho])]_ys)])"
using assms unfolding vsubst_def by(simp add: psubst_subst_compose)

lemma psubstEnv_vsubstEnv_compose:
assumes "goodEnv rho" and "goodEnv rho'"
shows "((rho &[y1 // y]_ys) &[rho']) = (rho &[(rho' [y  ((Var ys y1) #[rho'])]_ys)])"
using assms unfolding vsubstEnv_def by(simp add: psubstEnv_substEnv_compose)

lemma subst_psubst_compose:
assumes "good X" and "good Y" and "goodEnv rho"
shows "((X #[rho]) #[Y / y]_ys) = (X #[(rho &[Y / y]_ys)])"
unfolding subst_def substEnv_def using assms by(simp add: psubst_compose)

lemma substEnv_psubstEnv_compose:
assumes "goodEnv rho" and "good Y" and "goodEnv rho'"
shows "((rho &[rho']) &[Y / y]_ys) = (rho &[(rho' &[Y / y]_ys)])"
unfolding substEnv_def using assms by(simp add: psubstEnv_compose)

lemma psubst_subst_compose_freshEnv:
assumes "goodEnv rho" and "good X" and "good Y"
assumes "freshEnv ys y rho"
shows "((X #[Y / y]_ys) #[rho]) = ((X #[rho]) #[(Y #[rho]) / y]_ys)"
using assms by (simp add: subst_psubst_compose psubst_subst_compose)

lemma psubstEnv_substEnv_compose_freshEnv:
assumes "goodEnv rho" and "goodEnv rho'" and "good Y"
assumes "freshEnv ys y rho'"
shows "((rho &[Y / y]_ys) &[rho']) = ((rho &[rho']) &[(Y #[rho']) / y]_ys)"
using assms by (simp add: substEnv_psubstEnv_compose psubstEnv_substEnv_compose)

lemma vsubst_psubst_compose:
assumes "good X" and "goodEnv rho"
shows "((X #[rho]) #[y1 // y]_ys) = (X #[(rho &[y1 // y]_ys)])"
unfolding vsubst_def vsubstEnv_def using assms by(simp add: subst_psubst_compose)

lemma vsubstEnv_psubstEnv_compose:
assumes "goodEnv rho" and "goodEnv rho'"
shows "((rho &[rho']) &[y1 // y]_ys) = (rho &[(rho' &[y1 // y]_ys)])"
unfolding vsubstEnv_def using assms by(simp add: substEnv_psubstEnv_compose)

lemma subst_compose1:
assumes "good X" and "good Y1" and "good Y2"
shows "((X #[Y1 / y]_ys) #[Y2 / y]_ys) = (X #[(Y1 #[Y2 / y]_ys) / y]_ys)"
proof-
  have "goodEnv (idEnv [y  Y1]_ys)  goodEnv (idEnv [y  Y2]_ys)" using assms by simp
  thus ?thesis using ‹good X unfolding subst_def substEnv_def
  by(simp add: psubst_compose psubstEnv_updEnv)
qed

lemma substEnv_compose1:
assumes "goodEnv rho" and "good Y1" and "good Y2"
shows "((rho &[Y1 / y]_ys) &[Y2 / y]_ys) = (rho &[(Y1 #[Y2 / y]_ys) / y]_ys)"
by (simp add: assms psubstEnv_compose psubstEnv_updEnv_idEnv substEnv_def subst_psubst_idEnv)

lemma subst_vsubst_compose1:
assumes "good X" and "good Y" and "y  y1"
shows "((X #[y1 // y]_ys) #[Y / y]_ys) = (X #[y1 // y]_ys)"
using assms unfolding vsubst_def by(simp add: subst_compose1)

lemma substEnv_vsubstEnv_compose1:
assumes "goodEnv rho" and "good Y" and "y  y1"
shows "((rho &[y1 // y]_ys) &[Y / y]_ys) = (rho &[y1 // y]_ys)"
using assms unfolding vsubst_def vsubstEnv_def by(simp add: substEnv_compose1)

lemma vsubst_subst_compose1:
assumes "good X" and "good Y"
shows "((X #[Y / y]_ys) #[y1 // y]_ys) = (X #[(Y #[y1 // y]_ys) / y]_ys)"
using assms unfolding vsubst_def by(simp add: subst_compose1)

lemma vsubstEnv_substEnv_compose1:
assumes "goodEnv rho" and "good Y"
shows "((rho &[Y / y]_ys) &[y1 // y]_ys) = (rho &[(Y #[y1 // y]_ys) / y]_ys)"
using assms unfolding vsubst_def vsubstEnv_def by(simp add: substEnv_compose1)

lemma vsubst_compose1:
assumes "good X"
shows "((X #[y1 // y]_ys) #[y2 // y]_ys) = (X #[(y1 @ys[y2 / y]_ys) // y]_ys)"
using assms unfolding vsubst_def 
by(cases "y = y1") (auto simp: subst_compose1)

lemma vsubstEnv_compose1:
assumes "goodEnv rho"
shows "((rho &[y1 // y]_ys) &[y2 // y]_ys) = (rho &[(y1 @ys[y2 / y]_ys) // y]_ys)"
using assms unfolding vsubstEnv_def 
by(cases "y = y1") (auto simp: substEnv_compose1)

lemma subst_compose2:
assumes  "good X" and "good Y" and "good Z"
and "ys  zs  y  z" and fresh: "fresh ys y Z"
shows "((X #[Y / y]_ys) #[Z / z]_zs) = ((X #[Z / z]_zs) #[(Y #[Z / z]_zs) / y]_ys)"
by (metis assms fresh freshEnv_getEnv freshEnv_getEnv2 freshEnv_idEnv freshEnv_updEnv_I idEnv_preserves_good psubst_subst_compose_freshEnv 
 subst_psubst_idEnv updEnv_preserves_good)
 
lemma substEnv_compose2:
assumes  "goodEnv rho" and "good Y" and "good Z"
and "ys  zs  y  z" and fresh: "fresh ys y Z"
shows "((rho &[Y / y]_ys) &[Z / z]_zs) = ((rho &[Z / z]_zs) &[(Y #[Z / z]_zs) / y]_ys)"
  by (metis assms fresh freshEnv_updEnv_I getEnv_idEnv idEnv_preserves_good 
   option.discI psubstEnv_substEnv_compose_freshEnv substEnv_def 
  subst_psubst_idEnv updEnv_preserves_good)

lemma subst_vsubst_compose2:
assumes  "good X" and "good Z"
and "ys  zs  y  z" and fresh: "fresh ys y Z"
shows "((X #[y1 // y]_ys) #[Z / z]_zs) = ((X #[Z / z]_zs) #[((Var ys y1) #[Z / z]_zs) / y]_ys)"
using assms unfolding vsubst_def by(simp add: subst_compose2)

lemma substEnv_vsubstEnv_compose2:
assumes  "goodEnv rho" and "good Z"
and "ys  zs  y  z" and fresh: "fresh ys y Z"
shows "((rho &[y1 // y]_ys) &[Z / z]_zs) = ((rho &[Z / z]_zs) &[((Var ys y1) #[Z / z]_zs) / y]_ys)"
using assms unfolding vsubstEnv_def by(simp add: substEnv_compose2)

lemma vsubst_subst_compose2:
assumes  "good X" and "good Y"
and "ys  zs  y  {z,z1}"
shows "((X #[Y / y]_ys) #[z1 // z]_zs) = ((X #[z1 // z]_zs) #[(Y #[z1 // z]_zs) / y]_ys)"
using assms unfolding vsubst_def by(simp add: subst_compose2)

lemma vsubstEnv_substEnv_compose2:
assumes  "goodEnv rho" and "good Y"
and "ys  zs  y  {z,z1}"
shows "((rho &[Y / y]_ys) &[z1 // z]_zs) = ((rho &[z1 // z]_zs) &[(Y #[z1 // z]_zs) / y]_ys)"
using assms unfolding vsubst_def vsubstEnv_def by(simp add: substEnv_compose2)

lemma vsubst_compose2:
assumes  "good X"
and "ys  zs  y  {z,z1}"
shows "((X #[y1 // y]_ys) #[z1 // z]_zs) =
       ((X #[z1 // z]_zs) #[(y1 @ys[z1 / z]_zs) // y]_ys)"
by (metis vsubst_def Var_preserves_good assms vsubst_Var_simp vsubst_def 
    vsubst_subst_compose2) 

lemma vsubstEnv_compose2:
assumes "goodEnv rho"
and "ys  zs  y  {z,z1}"
shows "((rho &[y1 // y]_ys) &[z1 // z]_zs) =
       ((rho &[z1 // z]_zs) &[(y1 @ys[z1 / z]_zs) // y]_ys)"
by (metis Var_preserves_good assms 
vsubstEnv_def vsubstEnv_substEnv_compose2 vsubst_Var_simp)

subsection ‹Properties specific to variable-for-variable substitution›

(* Note: The results in this section cannot be lifted to environments, and therefore
we don't have ``environment versions" of these.  *)

lemma vsubstAll_ident:
fixes X::"('index,'bindex,'varSort,'var,'opSym)term" and
      A::"('index,'bindex,'varSort,'var,'opSym)abs" and
      P::"('index,'bindex,'varSort,'var,'opSym)param" and zs
assumes P: "goodPar P"
shows
"(good X 
  ( z. z  varsOf P  (X #[z // z]_zs) = X))

 (goodAbs A 
  ( z. z  varsOf P  (A $[z // z]_zs) = A))"
proof(induct rule: term_induct_fresh[of P])
  case (Op delta inp binp)
  then show ?case
  using assms
  unfolding vsubst_def vsubstAbs_def liftAll_def lift_def  
  by simp (auto simp: lift_def substInp_def2 substBinp_def2 vsubstInp_def2 
        split: option.splits)   
next
  case (Abs xs x X)
  then show ?case
  by (metis empty_iff insert_iff vsubstAbs_simp)
qed(insert assms, simp_all)
 
corollary vsubst_ident[simp]:
assumes "good X"
shows "(X #[z // z]_zs) = X"
using assms vsubstAll_ident[of "Par [z] [] [] []" X]
unfolding goodPar_def by simp

corollary subst_ident[simp]:
assumes "good X"
shows "(X #[(Var zs z) / z]_zs) = X"
using assms vsubst_ident unfolding vsubst_def by auto

lemma vsubstAll_swapAll:
fixes X::"('index,'bindex,'varSort,'var,'opSym)term" and
      A::"('index,'bindex,'varSort,'var,'opSym)abs" and
      P::"('index,'bindex,'varSort,'var,'opSym)param" and ys
assumes P: "goodPar P"
shows
"(good X 
  ( y1 y2. {y1,y2}  varsOf P  fresh ys y1 X 
            (X #[y1 // y2]_ys) = (X #[y1  y2]_ys)))

 (goodAbs A 
  ( y1 y2. {y1,y2}  varsOf P  freshAbs ys y1 A  
            (A $[y1 // y2]_ys) = (A $[y1  y2]_ys)))"
apply(induction rule: term_induct_fresh[OF P])
subgoal by (force simp add: sw_def) 
subgoal by simp (auto 
  simp: vsubstInp_def substInp_def2 vsubst_def swapInp_def 
              vsubstBinp_def substBinp_def2 vsubstAbs_def swapBinp_def  
              freshInp_def  freshBinp_def lift_def liftAll_def
  split: option.splits) 
subgoal by simp (metis Var_preserves_good fresh_Var_simp substAbs_simp sw_def
  vsubstAbs_def vsubst_def) .

corollary vsubst_eq_swap:
assumes "good X" and "y1 = y2  fresh ys y1 X"
shows "(X #[y1 // y2]_ys) = (X #[y1  y2]_ys)"
apply(cases "y1 = y2")  
using assms vsubstAll_swapAll[of "Par [y1, y2] [] [] []" X]
unfolding goodPar_def by auto

lemma skelAll_vsubstAll:
fixes X::"('index,'bindex,'varSort,'var,'opSym)term" and
      A::"('index,'bindex,'varSort,'var,'opSym)abs" and
      P::"('index,'bindex,'varSort,'var,'opSym)param" and ys
assumes P: "goodPar P"
shows
"(good X 
  ( y1 y2. {y1,y2}  varsOf P 
            skel (X #[y1 // y2]_ys) = skel X))

 (goodAbs A 
  ( y1 y2. {y1,y2}  varsOf P 
            skelAbs (A $[y1 // y2]_ys) = skelAbs A))"
proof(induction rule: term_induct_fresh[of P])
  case (Op delta inp binp)
  then show ?case 
  by (simp add: skelInp_def2 skelBinp_def2)
   (auto simp: vsubst_def vsubstInp_def substInp_def2
       vsubstAbs_def vsubstBinp_def substBinp_def2 lift_def liftAll_def
       split: option.splits) 
next
  case (Abs xs x X)
  then show ?case using assms  
  by simp (metis not_equals_and_not_equals_not_in 
     skelAbs_simp vsubstAbs_simp vsubst_preserves_good)
qed(insert assms, simp_all) 

corollary skel_vsubst:
assumes "good X"
shows "skel (X #[y1 // y2]_ys) = skel X"
using assms skelAll_vsubstAll[of "Par [y1, y2] [] [] []" X]
unfolding goodPar_def by simp

lemma subst_vsubst_trans:
assumes  "good X" and "good Y" and "fresh ys y1 X"
shows "((X #[y1 // y]_ys) #[Y / y1]_ys) = (X #[Y / y]_ys)"
using assms unfolding subst_def vsubst_def 
by (cases "y1 = y") (simp_all add: fresh_psubst_updEnv psubstEnv_updEnv_idEnv 
  psubst_compose updEnv_commute)

lemma vsubst_trans:
assumes  "good X" and "fresh ys y1 X"
shows "((X #[y1 // y]_ys) #[y2 // y1]_ys) = (X #[y2 // y]_ys)"
unfolding vsubst_def[of _ y2 y1] vsubst_def[of _ y2 y]
using assms by(simp add: subst_vsubst_trans)

lemma vsubst_commute:
assumes X: "good X"
and "xs  xs'  {x,y}  {x',y'} = {}" and "fresh xs x X" and "fresh xs' x' X"
shows "((X #[x // y]_xs) #[x' // y']_xs') = ((X #[x' // y']_xs') #[x // y]_xs)"
proof-
  have "fresh xs' x' (X #[x // y]_xs)"
  using assms by (intro vsubst_preserves_fresh) auto
  moreover have "fresh xs x (X #[x' // y']_xs')"
  using assms by (intro vsubst_preserves_fresh) auto
  ultimately show ?thesis using assms
  by (auto simp: vsubst_eq_swap intro!: swap_commute)
qed

subsection ‹Abstraction versions of the properties›

text‹Environment identity and update versus other operators:›

lemma psubstAbs_idEnv[simp]:
"goodAbs A  (A $[idEnv]) = A"
by(simp add: psubstAll_idEnv)

text‹Substitution versus other operators:›

corollary freshAbs_psubstAbs:
assumes "goodAbs A" and "goodEnv rho"
shows
"freshAbs zs z (A $[rho]) =
 ( ys y. freshAbs ys y A  freshImEnvAt zs z rho ys y)"
using assms freshAll_psubstAll[of "Par [z] [] [] [rho]"]
unfolding goodPar_def by simp

corollary freshAbs_psubstAbs_E1:
assumes "goodAbs A" and "goodEnv rho"
and "rho ys y = None" and "freshAbs zs z (A $[rho])"
shows "freshAbs ys y A  (ys  zs  y  z)"
using assms freshAbs_psubstAbs unfolding freshImEnvAt_def by fastforce

corollary freshAbs_psubstAbs_E2:
assumes "goodAbs A" and "goodEnv rho"
and "rho ys y = Some Y" and "freshAbs zs z (A $[rho])"
shows "freshAbs ys y A  fresh zs z Y"
using assms freshAbs_psubstAbs[of A rho] unfolding freshImEnvAt_def by fastforce

corollary freshAbs_psubstAbs_I1:
assumes "goodAbs A" and "goodEnv rho"
and "freshAbs zs z A" and "freshEnv zs z rho"
shows "freshAbs zs z (A $[rho])"
using assms apply(simp add: freshAbs_psubstAbs)
unfolding freshEnv_def liftAll_def freshImEnvAt_def by auto

corollary freshAbs_psubstAbs_I:
assumes "goodAbs A" and "goodEnv rho"
and "rho zs z = None  freshAbs zs z A" and
    " ys y Y. rho ys y = Some Y  freshAbs ys y A  fresh zs z Y"
shows "freshAbs zs z (A $[rho])"
using assms using option.exhaust_sel 
by (simp add: freshAbs_psubstAbs freshImEnvAt_def) blast  

lemma freshAbs_substAbs:
assumes "goodAbs A" and "good Y"
shows "freshAbs zs z (A $[Y / y]_ys) =
       (((zs = ys  z = y)  freshAbs zs z A)  (freshAbs ys y A  fresh zs z Y))"
unfolding substAbs_def using assms 
by (auto simp: freshAbs_psubstAbs freshImEnvAt_def)

lemma freshAbs_vsubstAbs:
assumes "goodAbs A"
shows "freshAbs zs z (A $[y1 // y]_ys) =
       (((zs = ys  z = y)  freshAbs zs z A) 
        (freshAbs ys y A  (zs  ys  z  y1)))"
unfolding vsubstAbs_def using assms by(auto simp: freshAbs_substAbs)

lemma substAbs_preserves_freshAbs:
assumes "goodAbs A" and "good Y"
and "freshAbs zs z A" and "fresh zs z Y"
shows "freshAbs zs z (A $[Y / y]_ys)"
using assms by(simp add: freshAbs_substAbs)

lemma vsubstAbs_preserves_freshAbs:
assumes "goodAbs A"
and "freshAbs zs z A" and "zs  ys  z  y1"
shows "freshAbs zs z (A $[y1 // y]_ys)"
using assms by(simp add: freshAbs_vsubstAbs)

lemma fresh_freshAbs_substAbs[simp]:
assumes "good Y" and "goodAbs A"
and "fresh ys y Y"
shows "freshAbs ys y (A $[Y / y]_ys)"
using assms by(simp add: freshAbs_substAbs)

lemma diff_freshAbs_vsubstAbs[simp]:
assumes "goodAbs A"
and "y  y1"
shows "freshAbs ys y (A $[y1 // y]_ys)"
using assms by(simp add: freshAbs_vsubstAbs)

lemma freshAbs_substAbs_E1:
assumes "goodAbs A" and "good Y"
and "freshAbs zs z (A $[Y / y]_ys)" and "zs  ys  z  y"
shows "freshAbs zs z A"
using assms by(auto simp: freshAbs_substAbs)

lemma freshAbs_vsubstAbs_E1:
assumes "goodAbs A"
and "freshAbs zs z (A $[y1 // y]_ys)" and "zs  ys  z  y"
shows "freshAbs zs z A"
using assms by(auto simp: freshAbs_vsubstAbs)

lemma freshAbs_substAbs_E2:
assumes "goodAbs A" and "good Y"
and "freshAbs zs z (A $[Y / y]_ys)"
shows "freshAbs ys y A  fresh zs z Y"
using assms by(simp add: freshAbs_substAbs)

lemma freshAbs_vsubstAbs_E2:
assumes "goodAbs A"
and "freshAbs zs z (A $[y1 // y]_ys)"
shows "freshAbs ys y A  zs  ys  z  y1"
using assms by(simp add: freshAbs_vsubstAbs)

corollary psubstAbs_cong[fundef_cong]:
assumes "goodAbs A" and "goodEnv rho" and "goodEnv rho'"
and " ys y. freshAbs ys y A  rho ys y = rho' ys y"
shows "(A $[rho]) = (A $[rho'])"
using assms psubstAll_cong[of "Par [] [] [] [rho,rho']"]
unfolding goodPar_def by simp

lemma freshAbs_psubstAbs_updEnv:
assumes "good X" and "goodAbs A" and "goodEnv rho"
and "freshAbs xs x A"
shows "(A $[rho [x  X]_xs]) = (A $[rho])"
using assms by (intro psubstAbs_cong) auto

corollary freshEnv_psubstAbs_ident[simp]:
fixes A :: "('index,'bindex,'varSort,'var,'opSym)abs"
assumes "goodAbs A" and "goodEnv rho"
and " zs z. freshEnv zs z rho  freshAbs zs z A"
shows "(A $[rho]) = A"
using assms psubstAll_ident[of "Par [] [] [] [rho]"]
unfolding goodPar_def by simp

lemma freshAbs_substAbs_ident[simp]:
assumes "good X" and "goodAbs A" and "freshAbs xs x A"
shows "(A $[X / x]_xs) = A"
by (simp add: assms freshAbs_psubstAbs_updEnv substAbs_def)

corollary substAbs_Abs[simp]:
assumes "good X" and "good Y"
shows "((Abs xs x X) $[Y / x]_xs) = Abs xs x X"
using assms by simp

lemma freshAbs_vsubstAbs_ident[simp]:
assumes "goodAbs A" and "freshAbs xs x A"
shows "(A $[x1 // x]_xs) = A"
using assms unfolding vsubstAbs_def by(auto simp: freshAbs_substAbs_ident)

lemma swapAbs_psubstAbs:
assumes "goodAbs A" and "goodEnv rho"
shows "((A $[rho]) $[z1  z2]_zs) = ((A $[z1  z2]_zs) $[rho &[z1  z2]_zs])"
using assms swapAll_psubstAll[of "Par [z1,z2] [] [] [rho]"]
unfolding goodPar_def by auto

lemma swapAbs_substAbs:
assumes "goodAbs A" and "good Y"
shows "((A $[Y / y]_ys) $[z1  z2]_zs) =
       ((A $[z1  z2]_zs) $[(Y #[z1  z2]_zs) / (y @ys[z1  z2]_zs)]_ys)"
proof-
  have 1: "(idEnv [(y @ys[z1  z2]_zs)  (Y #[z1  z2]_zs)]_ys) =
           ((idEnv [y  Y]_ys) &[z1  z2]_zs)"
  by(simp add: swapEnv_updEnv)
  show ?thesis
  unfolding substAbs_def 1 using assms by (intro swapAbs_psubstAbs) auto
qed

lemma swapAbs_vsubstAbs:
assumes "goodAbs A"
shows "((A $[y1 // y]_ys) $[z1  z2]_zs) =
       ((A $[z1  z2]_zs) $[(y1 @ys[z1  z2]_zs) // (y @ys[z1  z2]_zs)]_ys)"
using assms unfolding vsubstAbs_def
by(simp add: swapAbs_substAbs)

lemma psubstAbs_compose:
assumes "goodAbs A" and "goodEnv rho" and "goodEnv rho'"
shows "((A $[rho]) $[rho']) = (A $[(rho &[rho'])])"
using assms psubstAll_compose[of "Par [] [] [] [rho, rho']"]
unfolding goodPar_def by auto

lemma psubstAbs_substAbs_compose:
assumes "goodAbs A" and "good Y" and "goodEnv rho"
shows "((A $[Y / y]_ys) $[rho]) = (A $[(rho [y  (Y #[rho])]_ys)])"
by (simp add: assms psubstAbs_compose psubstEnv_updEnv_idEnv substAbs_def)

lemma psubstAbs_vsubstAbs_compose:
assumes "goodAbs A" and "goodEnv rho"
shows "((A $[y1 // y]_ys) $[rho]) = (A $[(rho [y  ((Var ys y1) #[rho])]_ys)])"
using assms unfolding vsubstAbs_def by(simp add: psubstAbs_substAbs_compose)

lemma substAbs_psubstAbs_compose:
assumes "goodAbs A" and "good Y" and "goodEnv rho"
shows "((A $[rho]) $[Y / y]_ys) = (A $[(rho &[Y / y]_ys)])"
unfolding substAbs_def substEnv_def using assms by(simp add: psubstAbs_compose)

lemma psubstAbs_substAbs_compose_freshEnv:
assumes "goodAbs A" and "goodEnv rho" and "good Y"
assumes "freshEnv ys y rho"
shows "((A $[Y / y]_ys) $[rho]) = ((A $[rho]) $[(Y #[rho]) / y]_ys)"
using assms by (simp add: substAbs_psubstAbs_compose psubstAbs_substAbs_compose)

lemma vsubstAbs_psubstAbs_compose:
assumes "goodAbs A" and "goodEnv rho"
shows "((A $[rho]) $[y1 // y]_ys) = (A $[(rho &[y1 // y]_ys)])"
unfolding vsubstAbs_def vsubstEnv_def using assms
by(simp add: substAbs_psubstAbs_compose)

lemma substAbs_compose1:
assumes "goodAbs A" and "good Y1" and "good Y2"
shows "((A $[Y1 / y]_ys) $[Y2 / y]_ys) = (A $[(Y1 #[Y2 / y]_ys) / y]_ys)"
by (metis assms idEnv_preserves_good psubstAbs_substAbs_compose substAbs_def 
  subst_psubst_idEnv updEnv_overwrite updEnv_preserves_good)

lemma substAbs_vsubstAbs_compose1:
assumes "goodAbs A" and "good Y" and "y  y1"
shows "((A $[y1 // y]_ys) $[Y / y]_ys) = (A $[y1 // y]_ys)"
using assms unfolding vsubstAbs_def by(simp add: substAbs_compose1)

lemma vsubstAbs_substAbs_compose1:
assumes "goodAbs A" and "good Y"
shows "((A $[Y / y]_ys) $[y1 // y]_ys) = (A $[(Y #[y1 // y]_ys) / y]_ys)"
using assms unfolding vsubstAbs_def vsubst_def by(simp add: substAbs_compose1)

lemma vsubstAbs_compose1:
assumes "goodAbs A"
shows "((A $[y1 // y]_ys) $[y2 // y]_ys) = (A $[(y1 @ys[y2 / y]_ys) // y]_ys)"
using assms unfolding vsubstAbs_def  
by(cases "y = y1") (auto simp: substAbs_compose1)

lemma substAbs_compose2:
assumes  "goodAbs A" and "good Y" and "good Z"
and "ys  zs  y  z" and fresh: "fresh ys y Z"
shows "((A $[Y / y]_ys) $[Z / z]_zs) = ((A $[Z / z]_zs) $[(Y #[Z / z]_zs) / y]_ys)"
by (metis assms fresh freshEnv_idEnv idEnv_preserves_good 
psubstAbs_substAbs_compose_freshEnv substAbs_def 
substEnv_idEnv substEnv_preserves_freshEnv_aux 
 subst_psubst_idEnv updEnv_preserves_good) 

lemma substAbs_vsubstAbs_compose2:
assumes "goodAbs A" and "good Z"
and "ys  zs  y  z" and fresh: "fresh ys y Z"
shows "((A $[y1 // y]_ys) $[Z / z]_zs) = ((A $[Z / z]_zs) $[((Var ys y1) #[Z / z]_zs) / y]_ys)"
using assms unfolding vsubstAbs_def by(simp add: substAbs_compose2)

lemma vsubstAbs_substAbs_compose2:
assumes  "goodAbs A" and "good Y"
and "ys  zs  y  {z,z1}"
shows "((A $[Y / y]_ys) $[z1 // z]_zs) = ((A $[z1 // z]_zs) $[(Y #[z1 // z]_zs) / y]_ys)"
using assms unfolding vsubstAbs_def vsubst_def by(simp add: substAbs_compose2)

lemma vsubstAbs_compose2:
assumes  "goodAbs A"
and "ys  zs  y  {z,z1}"
shows "((A $[y1 // y]_ys) $[z1 // z]_zs) =
       ((A $[z1 // z]_zs) $[(y1 @ys[z1 / z]_zs) // y]_ys)"
unfolding vsubstAbs_def
by (smt Var_preserves_good assms fresh_Var_simp insertCI 
   substAbs_compose2 vsubst_Var_simp vsubst_def) 

text‹Properties specific to variable-for-variable substitution:›

corollary vsubstAbs_ident[simp]:
assumes "goodAbs A"
shows "(A $[z // z]_zs) = A"
using assms vsubstAll_ident[of "Par [z] [] [] []" _ _ A]
unfolding goodPar_def by simp

corollary substAbs_ident[simp]:
assumes "goodAbs A"
shows "(A $[(Var zs z) / z]_zs) = A"
using assms vsubstAbs_ident unfolding vsubstAbs_def by auto

corollary vsubstAbs_eq_swapAbs:
assumes "goodAbs A" and "freshAbs ys y1 A"
shows "(A $[y1 // y2]_ys) = (A $[y1  y2]_ys)"
using assms vsubstAll_swapAll[of "Par [y1, y2] [] [] []" _ _ A]
unfolding goodPar_def by simp

corollary skelAbs_vsubstAbs:
assumes "goodAbs A"
shows "skelAbs (A $[y1 // y2]_ys) = skelAbs A"
using assms skelAll_vsubstAll[of "Par [y1, y2] [] [] []" _ _ A]
unfolding goodPar_def by simp

lemma substAbs_vsubstAbs_trans:
assumes  "goodAbs A" and "good Y" and "freshAbs ys y1 A"
shows "((A $[y1 // y]_ys) $[Y / y1]_ys) = (A $[Y / y]_ys)"
using assms unfolding substAbs_def vsubstAbs_def 
by (cases "y1 = y") (auto simp: freshAbs_psubstAbs_updEnv psubstAbs_compose 
  psubstEnv_updEnv_idEnv updEnv_commute)  

lemma vsubstAbs_trans:
assumes  "goodAbs A" and "freshAbs ys y1 A"
shows "((A $[y1 // y]_ys) $[y2 // y1]_ys) = (A $[y2 // y]_ys)"
unfolding vsubstAbs_def[of _ y2 y1] vsubstAbs_def[of _ y2 y]
using assms by(simp add: substAbs_vsubstAbs_trans)

lemmas good_psubstAll_freshAll_otherSimps =
psubst_idEnv psubstEnv_idEnv_id psubstAbs_idEnv
freshEnv_psubst_ident freshEnv_psubstAbs_ident

lemmas good_substAll_freshAll_otherSimps =
fresh_fresh_subst fresh_subst_ident fresh_substEnv_updEnv subst_ident
fresh_freshAbs_substAbs freshAbs_substAbs_ident substAbs_ident

lemmas good_vsubstAll_freshAll_otherSimps =
diff_fresh_vsubst fresh_vsubst_ident fresh_vsubstEnv_updEnv vsubst_ident
diff_freshAbs_vsubstAbs freshAbs_vsubstAbs_ident vsubstAbs_ident

lemmas good_allOpers_otherSimps =
good_swapAll_freshAll_otherSimps
good_psubstAll_freshAll_otherSimps
good_substAll_freshAll_otherSimps
good_vsubstAll_freshAll_otherSimps

lemmas good_item_simps =
param_simps
all_preserve_good
good_freeCons
good_allOpers_simps
good_allOpers_otherSimps

end  (* context FixVars *)

end

Theory Well_Sorted_Terms

section ‹Binding Signatures and well-sorted terms›

theory Well_Sorted_Terms
imports Terms
begin

text ‹This section introduces binding signatures
and well-sorted terms for them.  All the properties we proved for good terms are then
lifted to well-sorted terms.
›

subsection ‹Binding signatures›

text‹A {\em (binding) signature} consists of:
\\- an indication of which sorts of variables can be injected in
which sorts of terms;
\\- for any operation symbol, dwelling in a type ``opSym",
an indication of its result sort, its (nonbinding) arity, and its binding arity.

In addition, we have a predicate, ``wlsOpSym", that specifies which operations symbols
are well-sorted (or well-structured)
\footnote
{
We shall use ``wls" in many contexts as a prefix indicating well-sortedness or
well-structuredness.
}
 -- only these operation symbols will be considered in
forming terms.  In other words, the relevant collection of operation symbols is given not by the
whole type ``opSym", but by the predicate ``wlsOpSym".  This bit of extra flexibility
will be useful when (pre)instantiating the signature to concrete syntaxes.
(Note that the ``wlsOpSym" condition will be required for well-sorted terms as part of the notion of
well-sorted (free and bound) input, ``wlsInp" and ``wlsBinp".)
›

record ('index,'bindex,'varSort,'sort,'opSym)signature =
  varSortAsSort :: "'varSort  'sort"
  wlsOpSym :: "'opSym  bool"
  sortOf :: "'opSym  'sort"
  arityOf :: "'opSym  ('index, 'sort)input"
  barityOf :: "'opSym  ('bindex, 'varSort * 'sort)input"

subsection ‹The Binding Syntax locale›

(* From now on, all work on binding syntax shall be developed in this locale
   (or an extension of it): *)

(*
   Note also that currently locales do not allow datatype defs or records,
   reason for which the type of models has been defined outside. *)

text ‹For our signatures, we shall make some assumptions:
\\- For each sort of term, there is at most one sort of variables injectable  
in terms of that sort (i.e., ``varSortAsSort" is injective");
\\- The domains of arities (sets of indexes) are smaller than the set of variables
of each sort;
\\- The type of sorts is smaller than the set of variables
of each sort.

These are satisfiable assumptions, and in particular they are trivially satisfied by any finitary syntax
with bindings.
›

definition varSortAsSort_inj where
"varSortAsSort_inj Delta ==
inj (varSortAsSort Delta)"

definition arityOf_lt_var where
"arityOf_lt_var (_ :: 'var) Delta ==
  delta.
    wlsOpSym Delta delta  |{i. arityOf Delta delta i  None}| <o |UNIV :: 'var set|"

definition barityOf_lt_var where
"barityOf_lt_var (_ :: 'var) Delta ==
  delta.
    wlsOpSym Delta delta  |{i. barityOf Delta delta i  None}| <o |UNIV :: 'var set|"

definition sort_lt_var where
"sort_lt_var (_ :: 'sort) (_ :: 'var) ==
 |UNIV :: 'sort set| <o |UNIV :: 'var set|"

locale FixSyn =
  fixes dummyV :: 'var
  and Delta :: "('index,'bindex,'varSort,'sort,'opSym)signature"
  assumes
  (* The ``FixVars" assumptions, minus ``varSort-lt-var" (which follows form the rest): *)
      FixSyn_var_infinite: "var_infinite (undefined :: 'var)"
  and FixSyn_var_regular: "var_regular (undefined :: 'var)"
  (*  Plus the following: *)
  and varSortAsSort_inj: "varSortAsSort_inj Delta"
  and arityOf_lt_var: "arityOf_lt_var (undefined :: 'var) Delta"
  and barityOf_lt_var: "barityOf_lt_var (undefined :: 'var) Delta"
  and sort_lt_var: "sort_lt_var (undefined :: 'sort) (undefined :: 'var)"

context FixSyn
begin
lemmas FixSyn_assms =
FixSyn_var_infinite FixSyn_var_regular
varSortAsSort_inj arityOf_lt_var barityOf_lt_var
sort_lt_var
end

subsection ‹Definitions and basic properties of well-sortedness›

subsubsection ‹Notations and definitions›

(* Sorted parameters (again, for use in proofs): *)

datatype ('index,'bindex,'varSort,'var,'opSym,'sort)paramS =
  ParS "'varSort  'var list"
       "'sort  ('index,'bindex,'varSort,'var,'opSym)term list"
       "('varSort * 'sort)  ('index,'bindex,'varSort,'var,'opSym)abs list"
       "('index,'bindex,'varSort,'var,'opSym)env list"

fun varsOfS ::
"('index,'bindex,'varSort,'var,'opSym,'sort)paramS  'varSort  'var set"
where "varsOfS (ParS xLF _ _ _) xs = set (xLF xs)"

fun termsOfS ::
"('index,'bindex,'varSort,'var,'opSym,'sort)paramS 
 'sort  ('index,'bindex,'varSort,'var,'opSym)term set"
where "termsOfS (ParS _ XLF _ _) s = set (XLF s)"

fun absOfS ::
"('index,'bindex,'varSort,'var,'opSym,'sort)paramS 
 ('varSort * 'sort)  ('index,'bindex,'varSort,'var,'opSym)abs set"
where "absOfS (ParS _ _ ALF _) (xs,s) = set (ALF (xs,s))"

fun envsOfS ::
"('index,'bindex,'varSort,'var,'opSym,'sort)paramS  ('index,'bindex,'varSort,'var,'opSym)env set"
where "envsOfS (ParS _ _ _ rhoL) = set rhoL"

subsubsection ‹Sublocale of ``FixVars"›
  
lemma sort_lt_var_imp_varSort_lt_var:
assumes
**: "varSortAsSort_inj (Delta :: ('index,'bindex,'varSort,'sort,'opSym)signature)"
and ***: "sort_lt_var (undefined :: 'sort) (undefined :: 'var)"
shows "varSort_lt_var (undefined :: 'varSort) (undefined :: 'var)"
proof-
  have "|UNIV::'varSort set| ≤o |UNIV::'sort set|"
  using card_of_ordLeq ** unfolding  varSortAsSort_inj_def by auto
  thus ?thesis
  using ordLeq_ordLess_trans assms
  unfolding sort_lt_var_def varSort_lt_var_def by blast
qed

sublocale FixSyn < FixVars
where dummyV = dummyV and dummyVS = "undefined::'varSort"
using FixSyn_assms 
by unfold_locales (auto simp add: sort_lt_var_imp_varSort_lt_var)  

subsubsection ‹Abbreviations›

(*********************************************)
context FixSyn   (* scope all throughout the file *)
begin

abbreviation asSort where "asSort == varSortAsSort Delta"
abbreviation wlsOpS where "wlsOpS == wlsOpSym Delta"
abbreviation stOf where "stOf == sortOf Delta"
abbreviation arOf where "arOf == arityOf Delta"
abbreviation barOf where "barOf == barityOf Delta"

abbreviation empInp ::
"('index,('index,'bindex,'varSort,'var,'opSym)term)input"
where "empInp == λi. None"

abbreviation empAr :: "('index,'sort)input"
where "empAr == λi. None"

abbreviation empBinp :: "('bindex,('index,'bindex,'varSort,'var,'opSym)abs)input"
where "empBinp == λi. None"

abbreviation empBar :: "('bindex,'varSort * 'sort)input"
where "empBar == λi. None"

lemma freshInp_empInp[simp]:
"freshInp xs x empInp"
unfolding freshInp_def liftAll_def by simp

lemma swapInp_empInp[simp]:
"(empInp %[x1  x2]_xs) = empInp"
unfolding swapInp_def lift_def by simp

lemma psubstInp_empInp[simp]:
"(empInp %[rho]) = empInp"
unfolding psubstInp_def lift_def by simp

lemma substInp_empInp[simp]:
"(empInp %[Y / y]_ys) = empInp"
unfolding substInp_def by simp

lemma vsubstInp_empInp[simp]:
"(empInp %[y1 // y]_ys) = empInp"
unfolding vsubstInp_def by simp

lemma freshBinp_empBinp[simp]:
"freshBinp xs x empBinp"
unfolding freshBinp_def liftAll_def by simp

lemma swapBinp_empBinp[simp]:
"(empBinp %%[x1  x2]_xs) = empBinp"
unfolding swapBinp_def lift_def by simp

lemma psubstBinp_empBinp[simp]:
"(empBinp %%[rho]) = empBinp"
unfolding psubstBinp_def lift_def by simp

lemma substBinp_empBinp[simp]:
"(empBinp %%[Y / y]_ys) = empBinp"
unfolding substBinp_def by simp

lemma vsubstBinp_empBinp[simp]:
"(empBinp %%[y1 // y]_ys) = empBinp"
unfolding vsubstBinp_def by simp

lemmas empInp_simps =
freshInp_empInp swapInp_empInp psubstInp_empInp substInp_empInp vsubstInp_empInp
freshBinp_empBinp swapBinp_empBinp psubstBinp_empBinp substBinp_empBinp vsubstBinp_empBinp

subsubsection ‹Inner versions of the locale assumptions›

lemma varSortAsSort_inj_INNER: "inj asSort"
using varSortAsSort_inj
unfolding varSortAsSort_inj_def by simp

lemma asSort_inj[simp]:
"(asSort xs = asSort ys) = (xs = ys)"
using varSortAsSort_inj_INNER unfolding inj_on_def by auto

lemma arityOf_lt_var_INNER:
assumes "wlsOpS delta"
shows "|{i. arityOf Delta delta i  None}| <o |UNIV :: 'var set|"
using assms arityOf_lt_var unfolding arityOf_lt_var_def by simp

lemma barityOf_lt_var_INNER:
assumes "wlsOpS delta"
shows "|{i. barityOf Delta delta i  None}| <o |UNIV :: 'var set|"
using assms barityOf_lt_var unfolding barityOf_lt_var_def by simp

lemma sort_lt_var_INNER:
"|UNIV :: 'sort set| <o |UNIV :: 'var set|"
using sort_lt_var unfolding sort_lt_var_def by simp

lemma sort_le_var:
"|UNIV :: 'sort set| ≤o |UNIV :: 'var set|"
using sort_lt_var_INNER ordLess_imp_ordLeq by auto

lemma varSort_sort_lt_var:
"|UNIV :: ('varSort * 'sort) set| <o |UNIV :: 'var set|"
unfolding UNIV_Times_UNIV[symmetric]
using var_infinite_INNER varSort_lt_var_INNER sort_lt_var_INNER
by(rule card_of_Times_ordLess_infinite)

lemma varSort_sort_le_var:
"|UNIV :: ('varSort * 'sort) set| ≤o |UNIV :: 'var set|"
using varSort_sort_lt_var ordLess_imp_ordLeq by auto

subsubsection ‹Definitions of well-sorted items›

text ‹We shall only be interested in abstractions that pertain to some bound arities:›

definition isInBar where
"isInBar xs_s ==
  delta i. wlsOpS delta  barOf delta i = Some xs_s"

text ‹Well-sorted terms (according to the signature) are defined as expected (mutually inductively
together with well-sorted abstractions and inputs):›

inductive
wls :: "'sort  ('index,'bindex,'varSort,'var,'opSym)term  bool"
and
wlsAbs :: "'varSort * 'sort  ('index,'bindex,'varSort,'var,'opSym)abs  bool"
and
wlsInp :: "'opSym  ('index,('index,'bindex,'varSort,'var,'opSym)term)input  bool"
and
wlsBinp :: "'opSym  ('bindex,('index,'bindex,'varSort,'var,'opSym)abs)input  bool"
where
Var: "wls (asSort xs) (Var xs x)"
|
Op: "wlsInp delta inp; wlsBinp delta binp   wls (stOf delta) (Op delta inp binp)"
|
Inp:
"wlsOpS delta;
   i. (arOf delta i = None  inp i = None) 
        ( s X. arOf delta i = Some s  inp i = Some X  wls s X)
  wlsInp delta inp"
|
Binp:
"wlsOpS delta;
   i. (barOf delta i = None  binp i = None) 
        ( us s A. barOf delta i = Some (us,s)  binp i = Some A  wlsAbs (us,s) A)
  wlsBinp delta binp"
|
Abs: "isInBar (xs,s); wls s X  wlsAbs (xs,s) (Abs xs x X)"

lemmas Var_preserves_wls = wls_wlsAbs_wlsInp_wlsBinp.Var
lemmas Op_preserves_wls = wls_wlsAbs_wlsInp_wlsBinp.Op
lemmas Abs_preserves_wls = wls_wlsAbs_wlsInp_wlsBinp.Abs

lemma barOf_isInBar[simp]:
assumes "wlsOpS delta" and "barOf delta i = Some (us,s)"
shows "isInBar (us,s)"
unfolding isInBar_def using assms by blast

lemmas Cons_preserve_wls =
barOf_isInBar
Var_preserves_wls Op_preserves_wls
Abs_preserves_wls

declare Cons_preserve_wls [simp]

definition wlsEnv :: "('index,'bindex,'varSort,'var,'opSym)env  bool"
where
"wlsEnv rho ==
 ( ys. liftAll (wls (asSort ys)) (rho ys)) 
 ( ys. |{y. rho ys y  None}| <o |UNIV :: 'var set| )"

definition wlsPar :: "('index,'bindex,'varSort,'var,'opSym,'sort)paramS  bool"
where
"wlsPar P ==
 ( s.  X  termsOfS P s. wls s X) 
 ( xs s.  A  absOfS P (xs,s). wlsAbs (xs,s) A) 
 ( rho  envsOfS P. wlsEnv rho)"

lemma ParS_preserves_wls[simp]:
assumes " s X. X  set (XLF s)  wls s X"
and " xs s A. A  set (ALF (xs,s))  wlsAbs (xs,s) A"
and " rho. rho  set rhoF  wlsEnv rho"
shows "wlsPar (ParS xLF XLF ALF rhoF)"
using assms unfolding wlsPar_def by auto

lemma termsOfS_preserves_wls[simp]:
assumes "wlsPar P" and "X : termsOfS P s"
shows "wls s X"
using assms unfolding wlsPar_def by auto

lemma absOfS_preserves_wls[simp]:
assumes "wlsPar P" and "A : absOfS P (us,s)"
shows "wlsAbs (us,s) A"
using assms unfolding wlsPar_def by auto

lemma envsOfS_preserves_wls[simp]:
assumes "wlsPar P" and "rho : envsOfS P "
shows "wlsEnv rho"
using assms unfolding wlsPar_def by blast

lemma not_isInBar_absOfS_empty[simp]:
assumes *: "¬ isInBar (us,s)" and **: "wlsPar P"
shows "absOfS P (us,s) = {}"
proof-
  {fix A assume "A : absOfS P (us,s)"
   hence "wlsAbs (us,s) A" using ** by simp
   hence False using * using wlsAbs.cases by auto
  }
  thus ?thesis by auto
qed

lemmas paramS_simps =
varsOfS.simps termsOfS.simps absOfS.simps envsOfS.simps
ParS_preserves_wls
termsOfS_preserves_wls absOfS_preserves_wls envsOfS_preserves_wls
not_isInBar_absOfS_empty

subsubsection ‹Well-sorted exists›

lemma wlsInp_iff:
"wlsInp delta inp =
 (wlsOpS delta  sameDom (arOf delta) inp  liftAll2 wls (arOf delta) inp)" 
by (simp add: wlsInp.simps wls_wlsAbs_wlsInp_wlsBinp.Inp sameDom_and_liftAll2_iff) 
 

lemma wlsBinp_iff:
"wlsBinp delta binp =
(wlsOpS delta  sameDom (barOf delta) binp  liftAll2 wlsAbs (barOf delta) binp)"
by (simp add: wlsBinp.simps wls_wlsAbs_wlsInp_wlsBinp.Inp sameDom_and_liftAll2_iff) 

lemma exists_asSort_wls:
" X. wls (asSort xs) X"
by (intro exI[of _ "Var xs undefined"]) simp

lemma exists_wls_imp_exists_wlsAbs:
assumes  *: "isInBar (us,s)" and **: " X. wls s X"
shows " A. wlsAbs (us,s) A" 
proof-
  obtain X where "wls s X" using ** by blast
  hence "wlsAbs (us,s) (Abs us undefined X)" using * by simp
  thus ?thesis by blast
qed

lemma exists_asSort_wlsAbs:
assumes "isInBar (us,asSort xs)"
shows " A. wlsAbs (us,asSort xs) A"
proof-
  obtain X where "wls (asSort xs) X" using exists_asSort_wls by auto
  thus ?thesis using assms exists_wls_imp_exists_wlsAbs by auto
qed

text ‹Standard criterion for the non-emptiness of the sets of well-sorted terms for each sort,
by a well-founded relation and a function picking, for sorts not corresponding to varSorts,
an operation symbol as an ``inductive" witness for non-emptyness.
``witOpS" stands for ``witness operation symbol".›

definition witOpS where
"witOpS s delta R ==
 wlsOpS delta  stOf delta = s 
 liftAll (λs'. (s',s) : R) (arOf delta) 
 liftAll (λ(us,s'). (s',s) : R) (barOf delta)"

lemma wf_exists_wls:
assumes wf: "wf R" and *: "s. ( xs. s = asSort xs)  witOpS s (f s) R"
shows " X. wls s X"
proof(induction rule: wf_induct[of R])
  case (2 s)  
  show ?case
  proof(cases " xs. s = asSort xs")
    case True
    thus ?thesis using exists_asSort_wls by auto
  next
    let ?delta = "f s"
    case False
    hence delta: "wlsOpS ?delta" and st: "stOf ?delta = s"
    and ar: "liftAll (λs'. (s',s) : R) (arOf ?delta)"
    and bar: "liftAll (λ(us,s'). (s',s) : R) (barOf ?delta)"
    using * unfolding witOpS_def by auto
    (*  *)
    have 1: " i s'. arOf ?delta i = Some s'  ( X. wls s' X)"
    using ar 2 unfolding liftAll_def by simp
    let ?chi = "λi s' X. arOf ?delta i = Some s'  wls s' X"
    define inp where  
    "inp  (λi. (if arOf ?delta i = None
                   then None
                   else Some (SOME X.  s'. ?chi i s' X)))" 
    have inp: "wlsInp ?delta inp"
    unfolding wlsInp_iff sameDom_def liftAll2_def using delta 
    by (auto simp: inp_def 1 someI2_ex split: if_splits)  
    (*  *)
    have 1: " i us s'. barOf ?delta i = Some (us,s')  ( A. wlsAbs (us,s') A)"
    using bar 2 unfolding liftAll_def using delta exists_wls_imp_exists_wlsAbs by simp
    let ?chi = "λi us s' A. barOf ?delta i = Some (us,s')  wlsAbs (us,s') A"
    define binp where  
    "binp  (λi. (if barOf ?delta i = None
                   then None
                   else Some (SOME A.  us s'. ?chi i us s' A)))" 
    have binp: "wlsBinp ?delta binp"
    unfolding wlsBinp_iff sameDom_def liftAll2_def using delta 
    by (auto simp: binp_def 1 someI2_ex split: if_splits) 
    (*  *)
    have "wls s (Op ?delta inp binp)"
    using inp binp st using Op_preserves_wls[of ?delta inp binp] by simp
    thus ?thesis by blast
  qed
qed(insert assms, auto)

lemma wf_exists_wlsAbs:
assumes "isInBar (us,s)"
and "wf R" and "s. ( xs. s = asSort xs)  witOpS s (f s) R"
shows " A. wlsAbs (us,s) A"
using assms by (auto intro: exists_wls_imp_exists_wlsAbs wf_exists_wls)


subsubsection ‹Well-sorted implies Good›

lemma wlsInp_empAr_empInp[simp]:
assumes "wlsOpS delta" and "arOf delta = empAr"
shows "wlsInp delta empInp"
using assms
unfolding wlsInp_iff sameDom_def liftAll2_def by auto

lemma wlsBinp_empBar_empBinp[simp]:
assumes "wlsOpS delta" and "barOf delta = empBar"
shows "wlsBinp delta empBinp"
using assms unfolding wlsBinp_iff sameDom_def liftAll2_def by auto

lemmas empInp_otherSimps =
wlsInp_empAr_empInp wlsBinp_empBar_empBinp

lemma wlsAll_implies_goodAll:
"(wls s X  good X) 
 (wlsAbs (xs,s') A  goodAbs A) 
 (wlsInp delta inp  goodInp inp) 
 (wlsBinp delta binp  goodBinp binp)"
apply(induct rule: wls_wlsAbs_wlsInp_wlsBinp.induct) 
subgoal by auto
subgoal by auto 
subgoal unfolding goodInp_def liftAll_def 
by simp (smt Collect_cong arityOf_lt_var_INNER option.distinct(1) option.sel)
subgoal unfolding goodBinp_def liftAll_def 
by simp (smt Collect_cong barityOf_lt_var_INNER option.distinct(1) option.sel) 
subgoal by auto .

corollary wls_imp_good[simp]: "wls s X  good X"
by(simp add: wlsAll_implies_goodAll)

corollary wlsAbs_imp_goodAbs[simp]: "wlsAbs (xs,s) A  goodAbs A"
by(simp add: wlsAll_implies_goodAll)

corollary wlsInp_imp_goodInp[simp]: "wlsInp delta inp  goodInp inp"
by(simp add: wlsAll_implies_goodAll)

corollary wlsBinp_imp_goodBinp[simp]: "wlsBinp delta binp  goodBinp binp"
by(simp add: wlsAll_implies_goodAll)

lemma wlsEnv_imp_goodEnv[simp]: "wlsEnv rho  goodEnv rho"
unfolding wlsEnv_def goodEnv_def liftAll_def
by simp (insert wls_imp_good, blast)

lemmas wlsAll_imp_goodAll =
wls_imp_good wlsAbs_imp_goodAbs
wlsInp_imp_goodInp wlsBinp_imp_goodBinp
wlsEnv_imp_goodEnv

subsubsection ‹Swapping preserves well-sortedness›

lemma swapAll_pres_wlsAll:
"(wls s X  wls s (X #[z1  z2]_zs)) 
 (wlsAbs (xs,s') A  wlsAbs (xs,s') (A $[z1  z2]_zs)) 
 (wlsInp delta inp  wlsInp delta (inp %[z1  z2]_zs)) 
 (wlsBinp delta binp  wlsBinp delta (binp %%[z1  z2]_zs))"
proof(induct rule: wls_wlsAbs_wlsInp_wlsBinp.induct)
  case (Inp delta inp)
  then show ?case 
  unfolding wlsInp_iff sameDom_def liftAll2_def lift_def swapInp_def
  using option.sel by (fastforce simp add: split: option.splits)  
next
  case (Binp delta binp)
  then show ?case 
  unfolding wlsBinp_iff sameDom_def liftAll2_def lift_def swapBinp_def
  using option.sel by (fastforce simp add: split: option.splits) 
qed(insert Cons_preserve_wls, simp_all)

lemma swap_preserves_wls[simp]:
"wls s X  wls s (X #[z1  z2]_zs)"
by(simp add: swapAll_pres_wlsAll)

lemma swap_preserves_wls2[simp]:
assumes "good X"
shows "wls s (X #[z1  z2]_zs) = wls s X"
using assms swap_preserves_wls[of s "X #[z1  z2]_zs" zs z1 z2] by auto

lemma swap_preserves_wls3:
assumes "good X" and "good Y"
and "(X #[x1  x2]_xs) = (Y #[y1  y2]_ys)"
shows "wls s X = wls s Y"
by (metis assms swap_preserves_wls2)

lemma swapAbs_preserves_wls[simp]:
"wlsAbs (xs,x) A  wlsAbs (xs,x) (A $[z1  z2]_zs)"
by(simp add: swapAll_pres_wlsAll)

lemma swapInp_preserves_wls[simp]:
"wlsInp delta inp  wlsInp delta (inp %[z1  z2]_zs)"
by(simp add: swapAll_pres_wlsAll)

lemma swapBinp_preserves_wls[simp]:
"wlsBinp delta binp  wlsBinp delta (binp %%[z1  z2]_zs)"
by(simp add: swapAll_pres_wlsAll)

lemma swapEnvDom_preserves_wls:
assumes "wlsEnv rho"
shows "wlsEnv (swapEnvDom xs x y rho)"
proof-
  {fix xsa ys  let ?Left = "{ya. swapEnvDom xs x y rho ys ya  None}"
   have "|{y}  {ya. rho ys ya  None}| <o |UNIV :: 'var set|"
   using assms var_infinite_INNER card_of_Un_singl_ordLess_infinite
   unfolding wlsEnv_def by fastforce
   hence "|{x,y}  {ya. rho ys ya  None}| <o |UNIV :: 'var set|"
   using var_infinite_INNER card_of_Un_singl_ordLess_infinite by fastforce
   moreover
   {have "?Left  {x,y}  {ya. rho ys ya  None}"
    unfolding swapEnvDom_def sw_def[abs_def] by auto
    hence "|?Left| ≤o |{x,y}  {ya. rho ys ya  None}|"
    using card_of_mono1 by auto
   }
   ultimately have "|?Left| <o |UNIV :: 'var set|" 
   using ordLeq_ordLess_trans by blast
  }
  thus ?thesis using assms unfolding wlsEnv_def liftAll_def 
  by (auto simp add: swapEnvDom_def)
qed 

lemma swapEnvIm_preserves_wls:
assumes "wlsEnv rho"
shows "wlsEnv (swapEnvIm xs x y rho)"
using assms unfolding wlsEnv_def swapEnvIm_def liftAll_def lift_def 
by (auto split: option.splits) 

lemma swapEnv_preserves_wls[simp]:
assumes "wlsEnv rho"
shows "wlsEnv (rho &[z1  z2]_zs)"
unfolding swapEnv_def comp_def
using assms by(auto simp: swapEnvDom_preserves_wls swapEnvIm_preserves_wls)

lemmas swapAll_preserve_wls =
swap_preserves_wls swapAbs_preserves_wls
swapInp_preserves_wls swapBinp_preserves_wls
swapEnv_preserves_wls

lemma swapped_preserves_wls:
assumes "wls s X" and "(X,Y)  swapped"
shows "wls s Y" 
proof-
  have "(X,Y)  swapped  wls s X  wls s Y"
  by (induct rule: swapped.induct) auto
  thus ?thesis using assms by simp
qed

subsubsection ‹Inversion rules for well-sortedness›

lemma wlsAll_inversion:
"(wls s X 
  ( xs x. X = Var xs x  s = asSort xs) 
  ( delta inp binp. goodInp inp  goodBinp binp  X = Op delta inp binp 
                     stOf delta = s  wlsInp delta inp  wlsBinp delta binp))

(wlsAbs xs_s A 
 isInBar xs_s 
 ( x X. good X  A = Abs (fst xs_s) x X 
         wls (snd xs_s) X))

(wlsInp delta inp  True)

(wlsBinp delta binp  True)"
proof(induct rule: wls_wlsAbs_wlsInp_wlsBinp.induct)
  case (Abs xs s X x)
  then show ?case using swap_preserves_wls3 wls_imp_good 
  by (metis FixVars.Abs_ainj_ex FixVars_axioms snd_conv)
qed (auto simp: Abs_ainj_ex)
 
lemma conjLeft: "phi1  phi2; phi1  chi  chi"
by blast

lemma conjRight: "phi1  phi2; phi2  chi  chi"
by blast

(* For the next three lemmas, I could not use the simp, auto etc.
powerhorses freely -- for some reason, they loop… *)

lemma wls_inversion[rule_format]:
"wls s X 
 ( xs x. X = Var xs x  s = asSort xs) 
 ( delta inp binp. goodInp inp  goodBinp binp  X = Op delta inp binp 
                    stOf delta = s  wlsInp delta inp  wlsBinp delta binp)"
using wlsAll_inversion 
[of s X undefined undefined undefined undefined undefined]  
by (rule conjLeft) 

lemma wlsAbs_inversion[rule_format]:
"wlsAbs (xs,s) A 
 isInBar (xs,s) 
 ( x X. good X  A = Abs xs x X  wls s X)"
using wlsAll_inversion
[of undefined undefined "(xs,s)" A undefined undefined undefined]
by auto 

lemma wls_Var_simp[simp]:
"wls s (Var xs x) =  (s = asSort xs)"
using wls_inversion by auto

lemma wls_Op_simp[simp]:
assumes "goodInp inp" and "goodBinp binp"
shows
"wls s (Op delta inp binp) =
 (stOf delta = s  wlsInp delta inp  wlsBinp delta binp)"
using Op assms wls_inversion by blast 

lemma wls_Abs_simp[simp]:
assumes "good X"
shows "wlsAbs (xs,s) (Abs xs x X) = (isInBar (xs,s)  wls s X)"
using Abs assms wlsAbs_inversion by blast 

lemma wlsAll_inversion2:
"(wls s X  True)

(wlsAbs xs_s A 
 isInBar xs_s 
 ( x X. wls (snd xs_s) X  A = Abs (fst xs_s) x X))

(wlsInp delta inp  True)

(wlsBinp delta binp  True)"
by (induct rule: wls_wlsAbs_wlsInp_wlsBinp.induct)
  (auto simp add: Abs_ainj_ex simp del: not_None_eq)

lemma wlsAbs_inversion2[rule_format]:
"wlsAbs (xs,s) A 
 isInBar (xs,s)  ( x X. wls s X  A = Abs xs x X)"
using wlsAll_inversion2 by auto

corollary wlsAbs_Abs_varSort:
assumes X: "good X" and wlsAbs: "wlsAbs (xs,s) (Abs xs' x X)"
shows "xs = xs'" 
by (metis Abs_ainj_all X wlsAbs wlsAbs_inversion2 wls_imp_good)

lemma wlsAbs:
"wlsAbs (xs,s) A  
 isInBar (xs,s)  ( x X. wls s X  A = Abs xs x X)"
using Abs wlsAbs_inversion2 by blast

lemma wlsAbs_Abs[simp]:
assumes X: "good X"
shows "wlsAbs (xs',s) (Abs xs x X) = (isInBar (xs',s)  xs = xs'  wls s X)"
using assms wlsAbs_Abs_varSort by fastforce 

lemmas Cons_wls_simps =
wls_Var_simp wls_Op_simp wls_Abs_simp wlsAbs_Abs

subsection ‹Induction principles for well-sorted terms›

subsubsection ‹Regular induction›

(* See also the subsection on substitution of variables for variables
from the section on compositional properties
for an induction principle involving a choice between swap, subst and skeleton
for the abstraction case.  *)

theorem wls_templateInduct[case_names rel Var Op Abs]:
assumes
rel: " s X Y. wls s X;  (X,Y)  rel s  wls s Y  skel Y = skel X" and
Var: " xs x. phi (asSort xs) (Var xs x)" and
Op:
" delta inp binp.
   wlsInp delta inp;  wlsBinp delta binp;
    liftAll2 phi (arOf delta) inp; liftAll2 phiAbs (barOf delta) binp
    phi (stOf delta) (Op delta inp binp)" and
Abs:
" s xs x X.
   isInBar (xs,s); wls s X;  Y. (X,Y)  rel s  phi s Y
    phiAbs (xs,s) (Abs xs x X)"
shows
"(wls s X  phi s X) 
 (wlsAbs (xs,s') A  phiAbs (xs,s') A)"
proof-
  have "(good X  ( s. wls s X  phi s X)) 
        (goodAbs A  ( xs s. wlsAbs (xs,s) A  phiAbs (xs,s) A))"
  apply(induct rule: term_templateInduct[of "{(X,Y).  s. wls s X  (X,Y)  rel s}"])
  subgoal using rel wls_imp_good by blast 
  subgoal using Var by auto
  subgoal by (auto intro!: Op simp: wlsInp_iff wlsBinp_iff liftAll_def liftAll2_def)
  subgoal using Abs rel by simp blast . 
  thus ?thesis by auto
qed

theorem wls_rawInduct[case_names Var Op Abs]:
assumes
Var: " xs x. phi (asSort xs) (Var xs x)" and
Op:
" delta inp binp.
   wlsInp delta inp;  wlsBinp delta binp;
    liftAll2 phi (arOf delta) inp; liftAll2 phiAbs (barOf delta) binp
    phi (stOf delta) (Op delta inp binp)" and
Abs: " s xs x X. isInBar (xs,s); wls s X; phi s X  phiAbs (xs,s) (Abs xs x X)"
shows
"(wls s X  phi s X) 
 (wlsAbs (xs,s') A  phiAbs (xs,s') A)"
by (induct rule: wls_templateInduct[of "λs. Id"]) (simp_all add: assms)

subsubsection ‹Fresh induction›

text ‹First for an unspecified notion of parameter:›

theorem wls_templateInduct_fresh[case_names Par Rel Var Op Abs]:
fixes s X xs s' A phi phiAbs rel
and vars :: "'varSort  'var set"
and terms :: "'sort  ('index,'bindex,'varSort,'var,'opSym)term set"
and abs :: "('varSort * 'sort)  ('index,'bindex,'varSort,'var,'opSym)abs set"
and envs :: "('index,'bindex,'varSort,'var,'opSym)env set"
assumes
PAR:
" xs us s.
   ( |vars xs| <o |UNIV :: 'var set|  finite (vars xs)) 
   ( |terms s| <o |UNIV :: 'var set|  finite (terms s)) 
   ( |abs (us,s)| <o |UNIV :: 'var set|  finite (abs (us,s))) 
   ( X  terms s. wls s X) 
   ( A  abs (us,s). wlsAbs (us,s) A) 
   ( |envs| <o |UNIV :: 'var set|  finite (envs)) 
   ( rho  envs. wlsEnv rho)" and
rel: " s X Y. wls s X;  (X,Y)  rel s  wls s Y  skel Y = skel X" and
Var: " xs x. phi (asSort xs) (Var xs x)" and
Op:
" delta inp binp.
    wlsInp delta inp; wlsBinp delta binp;
     liftAll2 (λs X. phi s X) (arOf delta) inp;
     liftAll2 (λ(us,s) A. phiAbs (us,s) A) (barOf delta) binp
     phi (stOf delta) (Op delta inp binp)" and
Abs:
" s xs x X.
   isInBar (xs,s); wls s X;
    x  vars xs;
     s' Y. Y  terms s'  fresh xs x Y;
     xs' s' A. A  abs (xs',s')  freshAbs xs x A;
     rho. rho  envs  freshEnv xs x rho;
     Y. (X,Y)  rel s  phi s Y
    phiAbs (xs,s) (Abs xs x X)"
shows
"(wls s X  phi s X) 
 (wlsAbs (xs,s') A  phiAbs (xs,s') A)"
proof-
  let ?terms = " s. terms s"
  let ?abs = " xs s. abs (xs,s)"
  have " s. |terms s| <o |UNIV :: 'var set|"
  using PAR var_infinite_INNER finite_ordLess_infinite2 by blast
  hence 1:"|s. terms s| <o |UNIV :: 'var set|"
  using sort_lt_var_INNER var_regular_INNER regular_UNION by blast
  have " us s. |abs (us,s)| <o |UNIV :: 'var set|"
  using PAR var_infinite_INNER finite_ordLess_infinite2 by blast
  hence " us. |s. abs (us,s)| <o |UNIV :: 'var set|"
  by(auto simp add: sort_lt_var_INNER var_regular_INNER regular_UNION)
  hence 2: "| us s. abs (us,s)| <o |UNIV :: 'var set|"
  using varSort_lt_var_INNER var_regular_INNER by(auto simp add: regular_UNION)
  (* *)
  have "(good X  ( s. wls s X  phi s X)) 
        (goodAbs A  ( xs s. wlsAbs (xs,s) A  phiAbs (xs,s) A))"
  apply(induct rule: term_templateInduct_fresh
             [of vars ?terms ?abs envs
                 "{(X,Y).  s. wls s X  (X,Y)  rel s}"])
  subgoal for xs
  using PAR 1 2 apply simp_all using wls_imp_good wlsAbs_imp_goodAbs by blast+
  subgoal using assms by simp (meson wls_imp_good)
  subgoal using assms by simp
  subgoal using assms by simp  
    (smt liftAll2_def liftAll_def option.distinct(1) 
    option.sel wlsBinp.cases wlsInp_iff)
  subgoal using assms by simp metis . 
  thus ?thesis by auto
qed

text‹A version of the above not employing any relation for
  the abstraction case:›

theorem wls_rawInduct_fresh[case_names Par Var Op Abs]:
fixes s X xs s' A phi phiAbs
and vars :: "'varSort  'var set"
and terms :: "'sort  ('index,'bindex,'varSort,'var,'opSym)term set"
and abs :: "('varSort * 'sort)  ('index,'bindex,'varSort,'var,'opSym)abs set"
and envs :: "('index,'bindex,'varSort,'var,'opSym)env set"
assumes
PAR:
" xs us s.
   ( |vars xs| <o |UNIV :: 'var set|  finite (vars xs)) 
   ( |terms s| <o |UNIV :: 'var set|  finite (terms s)) 
   ( X  terms s. wls s X) 
   ( |abs (us,s)| <o |UNIV :: 'var set|  finite (abs (us,s))) 
   ( A  abs (us,s). wlsAbs (us,s) A) 
   ( |envs| <o |UNIV :: 'var set|  finite (envs)) 
   ( rho  envs. wlsEnv rho)" and
Var: " xs x. phi (asSort xs) (Var xs x)" and
Op:
" delta inp binp.
   wlsInp delta inp; wlsBinp delta binp;
    liftAll2 (λs X. phi s X) (arOf delta) inp;
    liftAll2 (λ(us,s) A. phiAbs (us,s) A) (barOf delta) binp
    phi (stOf delta) (Op delta inp binp)" and
Abs:
" s xs x X.
   isInBar (xs,s); wls s X;
    x  vars xs;
     s' Y. Y  terms s'  fresh xs x Y;
     us s' A. A  abs (us,s')  freshAbs xs x A;
     rho. rho  envs  freshEnv xs x rho;
    phi s X
    phiAbs (xs,s) (Abs xs x X)"
shows
"(wls s X  phi s X) 
 (wlsAbs (xs,s') A  phiAbs (xs,s') A)"
apply(induct rule: wls_templateInduct_fresh[of vars terms abs envs "λs. Id"])
using assms by auto

text‹Then for our notion of sorted parameter:›

theorem wls_induct_fresh[case_names Par Var Op Abs]:
fixes X :: "('index,'bindex,'varSort,'var,'opSym)term" and s and
      A :: "('index,'bindex,'varSort,'var,'opSym)abs" and xs s' and
      P :: "('index,'bindex,'varSort,'var,'opSym,'sort)paramS" and phi phiAbs
assumes
P: "wlsPar P" and
Var: " xs x. phi (asSort xs) (Var xs x)" and
Op:
" delta inp binp.
   wlsInp delta inp; wlsBinp delta binp;
    liftAll2 (λs X. phi s X) (arOf delta) inp;
    liftAll2 (λ(us,s) A. phiAbs (us,s) A) (barOf delta) binp
    phi (stOf delta) (Op delta inp binp)" and
Abs:
" s xs x X.
   isInBar (xs,s); wls s X;
    x  varsOfS P xs;
     s' Y. Y  termsOfS P s'  fresh xs x Y;
     us s' A. A  absOfS P (us,s')  freshAbs xs x A;
     rho. rho  envsOfS P  freshEnv xs x rho;
    phi s X
    phiAbs (xs,s) (Abs xs x X)"
shows
"(wls s X  phi s X) 
 (wlsAbs (xs,s') A  phiAbs (xs,s') A)"
proof(induct rule: wls_rawInduct_fresh
      [of "varsOfS P" "termsOfS P" "absOfS P" "envsOfS P" _ _ s X xs s' A])
  case (Par xs us s)
  then show ?case using assms by(cases P) simp
qed(insert assms, simp_all) 

subsubsection ‹The syntactic constructs are almost free (on well-sorted terms)›

(* Recall theorem Var_inj. *)

theorem wls_Op_inj[simp]:
assumes "wlsInp delta inp" and "wlsBinp delta binp"
and "wlsInp delta' inp'" and "wlsBinp delta' binp'"
shows
"(Op delta inp binp = Op delta' inp' binp') =
 (delta = delta'  inp = inp'  binp = binp')"
using assms by simp

lemma wls_Abs_ainj_all:
assumes "wls s X" and "wls s' X'"
shows
"(Abs xs x X = Abs xs' x' X') =
 (xs = xs' 
  ( y. (y = x  fresh xs y X)  (y = x'  fresh xs y X') 
        (X #[y  x]_xs) = (X' #[y  x']_xs)))"
using assms by(simp add: Abs_ainj_all)

theorem wls_Abs_swap_all:
assumes "wls s X" and "wls s X'"
shows
"(Abs xs x X = Abs xs x' X') =
 ( y. (y = x  fresh xs y X)  (y = x'  fresh xs y X') 
       (X #[y  x]_xs) = (X' #[y  x']_xs))"
using assms by(simp add: wls_Abs_ainj_all)

lemma wls_Abs_ainj_ex:
assumes  "wls s X" and "wls s X'"
shows
"(Abs xs x X = Abs xs' x' X') =
 (xs = xs' 
  ( y. y  {x,x'}  fresh xs y X  fresh xs y X' 
        (X #[y  x]_xs) = (X' #[y  x']_xs)))"
using assms by(simp add: Abs_ainj_ex)

theorem wls_Abs_swap_ex:
assumes  "wls s X" and "wls s X'"
shows
"(Abs xs x X = Abs xs x' X') =
 ( y. y  {x,x'}  fresh xs y X  fresh xs y X' 
       (X #[y  x]_xs) = (X' #[y  x']_xs))"
using assms by(simp add: wls_Abs_ainj_ex)

theorem wls_Abs_inj[simp]:
assumes "wls s X" and "wls s X'"
shows
"(Abs xs x X = Abs xs x X') =
 (X = X')"
using assms by (auto simp: wls_Abs_swap_all)

theorem wls_Abs_swap_cong[fundef_cong]:
assumes "wls s X" and "wls s X'"
and "fresh xs y X" and "fresh xs y X'"  and "(X #[y  x]_xs) = (X' #[y  x']_xs)"
shows "Abs xs x X = Abs xs x' X'"
using assms by (intro Abs_cong) auto

theorem wls_Abs_swap_fresh[simp]:
assumes "wls s X" and "fresh xs x' X"
shows "Abs xs x' (X #[x'  x]_xs) = Abs xs x X"
using assms by(simp add: Abs_swap_fresh)

theorem wls_Var_diff_Op[simp]:
assumes "wlsInp delta inp" and "wlsBinp delta binp"
shows "Var xs x  Op delta inp binp"
using assms by auto

theorem wls_Op_diff_Var[simp]:
assumes "wlsInp delta inp" and "wlsBinp delta binp"
shows "Op delta inp binp  Var xs x"
using assms by auto

theorem wls_nchotomy:
assumes "wls s X"
shows
"( xs x. asSort xs = s  X = Var xs x) 
 ( delta inp binp. stOf delta = s  wlsInp delta inp  wlsBinp delta binp
                     X = Op delta inp binp)"
 using assms wls.simps by force

lemmas wls_cases = wls_wlsAbs_wlsInp_wlsBinp.inducts(1)

lemmas wlsAbs_nchotomy = wlsAbs_inversion2 

theorem wlsAbs_cases:
assumes "wlsAbs (xs,s) A"
and " x X. isInBar (xs,s); wls s X  phiAbs (xs,s) (Abs xs x X)"
shows "phiAbs (xs,s) A"
using assms wlsAbs_nchotomy by blast

lemma wls_disjoint:
assumes "wls s X" and "wls s' X"
shows "s = s'" 
using assms term_nchotomy wls_imp_good by fastforce
 
lemma wlsAbs_disjoint:
assumes "wlsAbs (xs,s) A" and "wlsAbs (xs',s') A"
shows "xs = xs'  s = s'"
using assms abs_nchotomy wlsAbs_imp_goodAbs wls_disjoint by fastforce

lemmas wls_freeCons =
Var_inj wls_Op_inj wls_Var_diff_Op wls_Op_diff_Var wls_Abs_swap_fresh

subsection ‹The non-construct operators preserve well-sortedness›

lemma idEnv_preserves_wls[simp]:
"wlsEnv idEnv" 
proof-
  have "goodEnv idEnv" by simp
  thus ?thesis unfolding wlsEnv_def goodEnv_def liftAll_def idEnv_def by auto
qed

lemma updEnv_preserves_wls[simp]:
assumes "wlsEnv rho" and "wls (asSort xs) X"
shows "wlsEnv (rho [x  X]_xs)" 
proof-
  {fix ys
   let ?L = "{y. rho ys y  None}"
   let ?R = "{y. (rho [x  X]_xs) ys y  None}"
   have "?R  ?L Un {x}" by auto
   hence "|?R| ≤o |?L Un {x}|" by simp
   moreover
   {have "|?L| <o |UNIV :: 'var set|"
    using assms unfolding wlsEnv_def by simp
    moreover have "|{x}| <o |UNIV :: 'var set|"
    using var_infinite_INNER finite_ordLess_infinite by auto
    ultimately have "|?L Un {x}| <o  |UNIV :: 'var set|"
    using var_infinite_INNER card_of_Un_ordLess_infinite by blast
   }
   ultimately have "|?R| <o |UNIV :: 'var set|"
   using ordLeq_ordLess_trans by blast
  } note 0 = this
  have 1: "goodEnv (rho [x  X]_xs)" using assms by simp
  show ?thesis unfolding wlsEnv_def goodEnv_def 
   using 0 1 assms unfolding wlsEnv_def liftAll_def by auto
qed

lemma getEnv_preserves_wls[simp]:
assumes "wlsEnv rho" and "rho xs x = Some X"
shows "wls (asSort xs) X"
using assms unfolding wlsEnv_def liftAll_def by simp

lemmas envOps_preserve_wls =
idEnv_preserves_wls updEnv_preserves_wls
getEnv_preserves_wls

lemma psubstAll_preserves_wlsAll:
assumes P: "wlsPar P"
shows
"(wls s X  ( rho  envsOfS P. wls s (X #[rho]))) 
 (wlsAbs (xs,s') A  ( rho  envsOfS P. wlsAbs (xs,s') (A $[rho])))"
proof(induct rule: wls_induct_fresh[of P]) 
  case (Var xs x)
  show ?case 
  using assms apply safe subgoal for rho
  apply(cases "rho xs x") apply simp_all
  using getEnv_preserves_wls wlsPar_def by blast+ .
next
  case (Op delta inp binp)
  then show ?case using assms
  by (auto simp: 
  wlsInp_iff psubstInp_def wlsBinp_iff psubstBinp_def liftAll2_def lift_def 
  sameDom_def intro!: Op_preserves_wls split: option.splits)  
qed(insert assms, auto) 

lemma psubst_preserves_wls[simp]:
"wls s X; wlsEnv rho  wls s (X #[rho])"
using psubstAll_preserves_wlsAll[of "ParS (λ_. []) (λ_. []) (λ_. []) [rho]"]
unfolding wlsPar_def by auto

lemma psubstAbs_preserves_wls[simp]:
"wlsAbs (xs,s) A; wlsEnv rho  wlsAbs (xs,s) (A $[rho])"
using psubstAll_preserves_wlsAll[of "ParS (λ_. []) (λ_. []) (λ_. []) [rho]"]
unfolding wlsPar_def by auto

lemma psubstInp_preserves_wls[simp]:
assumes "wlsInp delta inp" and "wlsEnv rho"
shows "wlsInp delta (inp %[rho])"
using assms by (auto simp: wlsInp_iff psubstInp_def liftAll2_def lift_def 
 sameDom_def intro!: Op_preserves_wls split: option.splits)
 
lemma psubstBinp_preserves_wls[simp]:
assumes "wlsBinp delta binp" and "wlsEnv rho"
shows "wlsBinp delta (binp %%[rho])"
using assms by (auto simp: wlsBinp_iff psubstBinp_def liftAll2_def lift_def 
 sameDom_def intro!: Op_preserves_wls split: option.splits)

lemma psubstEnv_preserves_wls[simp]:
assumes "wlsEnv rho" and "wlsEnv rho'"
shows "wlsEnv (rho &[rho'])"
proof-
  {fix ys y Y
   assume "(rho &[rho']) ys y = Some Y"
   hence "wls (asSort ys) Y"
   using assms unfolding psubstEnv_def wlsEnv_def liftAll_def 
   by (cases "rho ys y") (auto simp add: assms) 
  }  
  moreover have "goodEnv (rho &[rho'])" using assms by simp
  ultimately show ?thesis 
  unfolding goodEnv_def wlsEnv_def psubstEnv_def wlsEnv_def liftAll_def 
  by (auto simp add: assms) 
qed

lemmas psubstAll_preserve_wls =
psubst_preserves_wls psubstAbs_preserves_wls
psubstInp_preserves_wls psubstBinp_preserves_wls
psubstEnv_preserves_wls

lemma subst_preserves_wls[simp]:
assumes "wls s X" and "wls (asSort ys) Y"
shows "wls s (X #[Y / y]_ys)"
using assms unfolding subst_def by simp

lemma substAbs_preserves_wls[simp]:
assumes "wlsAbs (xs,s) A" and "wls (asSort ys) Y"
shows "wlsAbs (xs,s) (A $[Y / y]_ys)"
using assms unfolding substAbs_def by simp

lemma substInp_preserves_wls[simp]:
assumes "wlsInp delta inp" and "wls (asSort ys) Y"
shows "wlsInp delta (inp %[Y / y]_ys)"
using assms unfolding substInp_def by simp

lemma substBinp_preserves_wls[simp]:
assumes "wlsBinp delta binp" and "wls (asSort ys) Y"
shows "wlsBinp delta (binp %%[Y / y]_ys)"
using assms unfolding substBinp_def by simp

lemma substEnv_preserves_wls[simp]:
assumes "wlsEnv rho" and "wls (asSort ys) Y"
shows "wlsEnv (rho &[Y / y]_ys)"
using assms unfolding substEnv_def by simp

lemmas substAll_preserve_wls =
subst_preserves_wls substAbs_preserves_wls
substInp_preserves_wls substBinp_preserves_wls
substEnv_preserves_wls

lemma vsubst_preserves_wls[simp]:
assumes "wls s Y"
shows "wls s (Y #[x1 // x]_xs)"
using assms unfolding vsubst_def by simp

lemma vsubstAbs_preserves_wls[simp]:
assumes "wlsAbs (us,s) A"
shows "wlsAbs (us,s) (A $[x1 // x]_xs)"
using assms unfolding vsubstAbs_def by simp

lemma vsubstInp_preserves_wls[simp]:
assumes "wlsInp delta inp"
shows "wlsInp delta (inp %[x1 // x]_xs)"
using assms unfolding vsubstInp_def by simp

lemma vsubstBinp_preserves_wls[simp]:
assumes "wlsBinp delta binp"
shows "wlsBinp delta (binp %%[x1 // x]_xs)"
using assms unfolding vsubstBinp_def by simp

lemma vsubstEnv_preserves_wls[simp]:
assumes "wlsEnv rho"
shows "wlsEnv (rho &[x1 // x]_xs)"
using assms unfolding vsubstEnv_def by simp

lemmas vsubstAll_preserve_wls = vsubst_preserves_wls vsubstAbs_preserves_wls
vsubstInp_preserves_wls vsubstBinp_preserves_wls vsubstEnv_preserves_wls

lemmas all_preserve_wls = Cons_preserve_wls swapAll_preserve_wls psubstAll_preserve_wls envOps_preserve_wls
substAll_preserve_wls vsubstAll_preserve_wls

subsection ‹Simplification rules for swapping, substitution, freshness and skeleton›

(* Recall theorem swap_Var_simp.  *)

theorem wls_swap_Op_simp[simp]:
assumes "wlsInp delta inp" and "wlsBinp delta binp"
shows
"((Op delta inp binp) #[x1  x2]_xs) =
 Op delta (inp %[x1  x2]_xs) (binp %%[x1  x2]_xs)"
using assms by simp

theorem wls_swapAbs_simp[simp]:
assumes "wls s X"
shows "((Abs xs x X) $[y1  y2]_ys) = Abs xs (x @xs[y1  y2]_ys) (X #[y1  y2]_ys)"
using assms by simp

lemmas wls_swapAll_simps =
swap_Var_simp wls_swap_Op_simp wls_swapAbs_simp

(* Recall theorem fresh_Var_simp. *)

theorem wls_fresh_Op_simp[simp]:
assumes "wlsInp delta inp" and "wlsBinp delta binp"
shows
"fresh xs x (Op delta inp binp) =
 (freshInp xs x inp  freshBinp xs x binp)"
using assms by simp

theorem wls_freshAbs_simp[simp]:
assumes "wls s X"
shows "freshAbs ys y (Abs xs x X) = (ys = xs  y = x  fresh ys y X)"
using assms by simp

lemmas wls_freshAll_simps =
fresh_Var_simp wls_fresh_Op_simp wls_freshAbs_simp

(* Recall theorem skel_Var_simp *)

theorem wls_skel_Op_simp[simp]:
assumes "wlsInp delta inp" and "wlsBinp delta binp"
shows
"skel (Op delta inp binp) = Branch (skelInp inp) (skelBinp binp)"
using assms by simp

(* The next is not a simplification rule, but belongs here: *)

lemma wls_skelInp_def2:
assumes "wlsInp delta inp"
shows "skelInp inp = lift skel inp"
using assms by(simp add: skelInp_def2)

lemma wls_skelBinp_def2:
assumes "wlsBinp delta binp"
shows "skelBinp binp = lift skelAbs binp"
using assms by(simp add: skelBinp_def2)

theorem wls_skelAbs_simp[simp]:
assumes "wls s X"
shows "skelAbs (Abs xs x X) = Branch (λi. Some (skel X)) Map.empty"
using assms by simp

lemmas wls_skelAll_simps =
skel_Var_simp wls_skel_Op_simp wls_skelAbs_simp

theorem wls_psubst_Var_simp1[simp]:
assumes "wlsEnv rho" and "rho xs x = None"
shows "((Var xs x) #[rho]) = Var xs x"
using assms by simp

theorem wls_psubst_Var_simp2[simp]:
assumes "wlsEnv rho" and "rho xs x = Some X"
shows "((Var xs x) #[rho]) = X"
using assms by simp

theorem wls_psubst_Op_simp[simp]:
assumes "wlsInp delta inp" and "wlsBinp delta binp" and "wlsEnv rho"
shows
"((Op delta inp binp) #[rho]) = Op delta (inp %[rho]) (binp %%[rho])"
using assms by simp

theorem wls_psubstAbs_simp[simp]:
assumes "wls s X" and "wlsEnv rho" and "freshEnv xs x rho"
shows "((Abs xs x X) $[rho]) = Abs xs x (X #[rho])"
  using assms by simp

lemmas wls_psubstAll_simps =
wls_psubst_Var_simp1 wls_psubst_Var_simp2 wls_psubst_Op_simp wls_psubstAbs_simp

(* Recall lemmas getEnv_idEnv, getEnv_updEnv1 and getEnv_updEnv2. *)

lemmas wls_envOps_simps =
getEnv_idEnv getEnv_updEnv1 getEnv_updEnv2

theorem wls_subst_Var_simp1[simp]:
assumes "wls (asSort ys) Y"
and "ys  xs  y  x "
shows "((Var xs x) #[Y / y]_ys) = Var xs x"
using assms unfolding subst_def by auto

theorem wls_subst_Var_simp2[simp]:
assumes "wls (asSort xs) Y"
shows "((Var xs x) #[Y / x]_xs) = Y"
using assms unfolding subst_def by auto

theorem wls_subst_Op_simp[simp]:
assumes "wls (asSort ys) Y"
 and "wlsInp delta inp" and "wlsBinp delta binp"
shows
"((Op delta inp binp) #[Y / y]_ys) =
 Op delta (inp %[Y / y]_ys) (binp %%[Y / y]_ys)"
using assms unfolding subst_def substInp_def
                      substAbs_def substBinp_def by auto

theorem wls_substAbs_simp[simp]:
assumes "wls (asSort ys) Y"
and "wls s X" and "xs  ys  x  y" and "fresh xs x Y"
shows "((Abs xs x X) $[Y / y]_ys) = Abs xs x (X #[Y / y]_ys)"
proof-
  have "freshEnv xs x (idEnv [y  Y]_ys)" unfolding freshEnv_def liftAll_def
  using assms by simp
  thus ?thesis using assms unfolding subst_def substAbs_def by auto
qed

lemmas wls_substAll_simps =
wls_subst_Var_simp1 wls_subst_Var_simp2 wls_subst_Op_simp wls_substAbs_simp

(* Recall theorem vsubst_Var_simp. *)

theorem wls_vsubst_Op_simp[simp]:
assumes "wlsInp delta inp" and "wlsBinp delta binp"
shows
"((Op delta inp binp) #[y1 // y]_ys) =
 Op delta (inp %[y1 // y]_ys) (binp %%[y1 // y]_ys)"
using assms unfolding vsubst_def vsubstInp_def
                      vsubstAbs_def vsubstBinp_def by simp

theorem wls_vsubstAbs_simp[simp]:
assumes "wls s X" and
        "xs  ys  x  {y,y1}"
shows "((Abs xs x X) $[y1 // y]_ys) = Abs xs x (X #[y1 // y]_ys)"
using assms unfolding vsubst_def vsubstAbs_def by simp

lemmas wls_vsubstAll_simps =
vsubst_Var_simp wls_vsubst_Op_simp wls_vsubstAbs_simp

(* Recall theorem swap_swapped. *)

theorem wls_swapped_skel:
assumes "wls s X" and "(X,Y)  swapped"
shows "skel Y = skel X"
apply(rule swapped_skel) using assms by auto

theorem wls_obtain_rep:
assumes "wls s X" and FRESH: "fresh xs x' X"
shows " X'. skel X' = skel X  (X,X')  swapped  wls s X'  Abs xs x X = Abs xs x' X'"
proof-
  have 0: "skel (X #[x'  x]_xs) = skel X" using assms by(simp add: skel_swap)
  have 1: "wls s (X #[x'  x]_xs)" using assms swap_preserves_wls by auto
  have 2: "(X, X #[x'  x]_xs)  swapped" using Var swap_swapped by auto
  show ?thesis using assms 0 1 2 by fastforce
qed

lemmas wls_allOpers_simps =
wls_swapAll_simps
wls_freshAll_simps
wls_skelAll_simps
wls_envOps_simps
wls_psubstAll_simps
wls_substAll_simps
wls_vsubstAll_simps

subsection ‹The ability to pick fresh variables›

theorem wls_single_non_fresh_ordLess_var:
"wls s X  |{x. ¬ fresh xs x X}| <o |UNIV :: 'var set|"
by(simp add: single_non_fresh_ordLess_var)

theorem wls_single_non_freshAbs_ordLess_var:
"wlsAbs (us,s) A  |{x. ¬ freshAbs xs x A}| <o |UNIV :: 'var set|"
by(simp add: single_non_freshAbs_ordLess_var)

theorem wls_obtain_fresh:
fixes V::"'varSort  'var set" and
      XS::"'sort  ('index,'bindex,'varSort,'var,'opSym)term set" and
      AS::"'varSort  'sort  ('index,'bindex,'varSort,'var,'opSym)abs set" and
      Rho::"('index,'bindex,'varSort,'var,'opSym)env set" and zs
assumes VVar: " xs. |V xs| <o |UNIV :: 'var set|  finite (V xs)"
and XSVar: " s. |XS s| <o |UNIV :: 'var set|  finite (XS s)"
and ASVar: " xs s. |AS xs s| <o |UNIV :: 'var set|  finite (AS xs s)"
and XSwls: " s.  X  XS s. wls s X"
and ASwls: " xs s.  A  AS xs s. wlsAbs (xs,s) A"
and RhoVar: "|Rho| <o |UNIV :: 'var set|  finite Rho"
and Rhowls: " rho  Rho. wlsEnv rho"
shows
" z. ( xs. z  V xs) 
      ( s.  X  XS s. fresh zs z X) 
      ( xs s.  A  AS xs s. freshAbs zs z A) 
      ( rho  Rho. freshEnv zs z rho)"
proof-
  let ?VG = " xs. V xs"    let ?XSG = " s. XS s"   let ?ASG = " xs s. AS xs s"
  have " xs. |V xs| <o |UNIV :: 'var set|" using VVar finite_ordLess_var by auto
  hence 1: "|?VG| <o |UNIV :: 'var set|"
  using var_regular_INNER varSort_lt_var_INNER regular_UNION by blast
  have " s. |XS s| <o |UNIV :: 'var set|" using XSVar finite_ordLess_var by auto
  hence 2: "|?XSG| <o |UNIV :: 'var set|"
  using var_regular_INNER sort_lt_var_INNER regular_UNION by blast
  have " xs s. |AS xs s| <o |UNIV :: 'var set|" using ASVar finite_ordLess_var by auto
  hence " xs. | s. AS xs s| <o |UNIV :: 'var set|"
  using var_regular_INNER sort_lt_var_INNER regular_UNION by blast
  hence 3: "|?ASG| <o |UNIV :: 'var set|"
  using var_regular_INNER varSort_lt_var_INNER by (auto simp add: regular_UNION)
  have " z. z  ?VG 
             ( X  ?XSG. fresh zs z X) 
             ( A  ?ASG. freshAbs zs z A) 
             ( rho  Rho. freshEnv zs z rho)"
  using assms 1 2 3 by (intro obtain_fresh) fastforce+
  thus ?thesis by auto
qed

theorem wls_obtain_fresh_paramS:
assumes "wlsPar P"
shows
" z.
 ( xs. z  varsOfS P xs) 
 ( s.  X  termsOfS P s. fresh zs z X) 
 ( us s.  A  absOfS P (us,s). freshAbs zs z A) 
 ( rho  envsOfS P. freshEnv zs z rho)"
using assms  by(cases P) (auto intro: wls_obtain_fresh)

lemma wlsAbs_freshAbs_nchotomy:
assumes A: "wlsAbs (xs,s) A" and fresh: "freshAbs xs x A"
shows " X. wls s X  A = Abs xs x X"
proof-
  {assume "wlsAbs (xs,s) A"
   hence "freshAbs xs x A  ( X. wls s X  A = Abs xs x X)"
   using fresh wls_obtain_rep[of s _ xs x] by (fastforce elim!: wlsAbs_cases)
  }
  thus ?thesis using assms by auto
qed

theorem wlsAbs_fresh_nchotomy:
assumes A: "wlsAbs (xs,s) A" and P: "wlsPar P"
shows " x X. A = Abs xs x X 
               wls s X 
               ( ys. x  varsOfS P ys) 
               ( s'.  Y  termsOfS P s'. fresh xs x Y) 
               ( us s'.  B  absOfS P (us,s'). freshAbs xs x B) 
               ( rho  envsOfS P. freshEnv xs x rho)"
proof-
  let ?chi =
  "λ x. ( xs. x  varsOfS P xs) 
        ( s'.  Y  termsOfS P s'. fresh xs x Y) 
        ( us s'. B  (if us = xs  s' = s then {A} else {})  absOfS P (us,s'). freshAbs xs x B) 
        ( rho  envsOfS P. freshEnv xs x rho)"
  have " x. ?chi x" 
  using A P by (intro wls_obtain_fresh) (cases P, auto)+
  then obtain x where 1: "?chi x" by blast
  hence "freshAbs xs x A" by fastforce
  then obtain X where X: "wls s X" and 2: "A = Abs xs x X"
  using A 1 wlsAbs_freshAbs_nchotomy[of xs s A x] by auto
  thus ?thesis using 1 by blast
qed

theorem wlsAbs_fresh_cases:
assumes "wlsAbs (xs,s) A" and "wlsPar P"
and " x X.
          wls s X;
            ys. x  varsOfS P ys;
            s' Y. Y  termsOfS P s'  fresh xs x Y;
            us s' B. B  absOfS P (us,s')  freshAbs xs x B;
            rho. rho  envsOfS P  freshEnv xs x rho
            phi (xs,s) (Abs xs x X) P"
shows "phi (xs,s) A P"
by (metis assms wlsAbs_fresh_nchotomy)
 

subsection ‹Compositionality properties of freshness and swapping›

subsubsection ‹W.r.t. terms›

theorem wls_swap_ident[simp]:
assumes "wls s X"
shows "(X #[x  x]_xs) = X"
using assms by simp

theorem wls_swap_compose:
assumes "wls s X"
shows "((X #[x  y]_zs) #[x'  y']_zs') =
       ((X #[x'  y']_zs') #[(x @zs[x'  y']_zs')  (y @zs[x'  y']_zs')]_zs)"
using assms by (intro swap_compose) auto

theorem wls_swap_commute:
"wls s X; zs  zs'  {x,y}  {x',y'} = {} 
 ((X #[x  y]_zs) #[x'  y']_zs') = ((X #[x'  y']_zs') #[x  y]_zs)"
by (intro swap_commute) auto

theorem wls_swap_involutive[simp]:
assumes "wls s X"
shows "((X #[x  y]_zs) #[x  y]_zs) = X"
using assms by simp

theorem wls_swap_inj[simp]:
assumes "wls s X" and "wls s X'"
shows
"((X #[x  y]_zs) = (X' #[x  y]_zs)) =
 (X = X')"
using assms by (metis wls_swap_involutive)

(* Recall theorem swap_sym. *)

theorem wls_swap_involutive2[simp]:
assumes "wls s X"
shows "((X #[x  y]_zs) #[y  x]_zs) = X"
using assms by (simp  add: swap_sym)

theorem wls_swap_preserves_fresh[simp]:
assumes "wls s X"
shows "fresh xs (x @xs[y1  y2]_ys) (X #[y1  y2]_ys) = fresh xs x X"
using assms by simp

theorem wls_swap_preserves_fresh_distinct:
assumes "wls s X" and
       "xs  ys  x  {y1,y2}"
shows "fresh xs x (X #[y1  y2]_ys) = fresh xs x X"
using assms by(intro swap_preserves_fresh_distinct) auto

theorem wls_fresh_swap_exchange1:
assumes "wls s X"
shows "fresh xs x2 (X #[x1  x2]_xs) = fresh xs x1 X"
using assms by (intro fresh_swap_exchange1) auto

theorem wls_fresh_swap_exchange2:
assumes "wls s X"
shows "fresh xs x2 (X #[x2  x1]_xs) = fresh xs x1 X"
using assms by (intro fresh_swap_exchange2) fastforce+

theorem wls_fresh_swap_id[simp]:
assumes "wls s X" and "fresh xs x1 X"  and "fresh xs x2 X"
shows "(X #[x1  x2]_xs) = X"
using assms by simp

theorem wls_fresh_swap_compose:
assumes "wls s X" and "fresh xs y X"  and "fresh xs z X"
shows "((X #[y  x]_xs) #[z  y]_xs) = (X #[z  x]_xs)"
using assms by (intro fresh_swap_compose) auto

theorem wls_skel_swap:
assumes "wls s X"
shows "skel (X #[x1  x2]_xs) = skel X"
using assms by (intro skel_swap) auto

subsubsection ‹W.r.t. environments›

theorem wls_swapEnv_ident[simp]:
assumes "wlsEnv rho"
shows "(rho &[x  x]_xs) = rho"
using assms by simp

theorem wls_swapEnv_compose:
assumes "wlsEnv rho"
shows "((rho &[x  y]_zs) &[x'  y']_zs') =
       ((rho &[x'  y']_zs') &[(x @zs[x'  y']_zs')  (y @zs[x'  y']_zs')]_zs)"
using assms by (intro swapEnv_compose) auto

theorem wls_swapEnv_commute:
"wlsEnv rho; zs  zs'  {x,y}  {x',y'} = {} 
 ((rho &[x  y]_zs) &[x'  y']_zs') = ((rho &[x'  y']_zs') &[x  y]_zs)"
by (intro swapEnv_commute) fastforce+

theorem wls_swapEnv_involutive[simp]:
assumes "wlsEnv rho"
shows "((rho &[x  y]_zs) &[x  y]_zs) = rho"
using assms by simp

theorem wls_swapEnv_inj[simp]:
assumes "wlsEnv rho" and "wlsEnv rho'"
shows
"((rho &[x  y]_zs) = (rho' &[x  y]_zs)) =
 (rho = rho')" 
by (metis assms wls_swapEnv_involutive) 

(* Recall theorem swapEnv_sym. *)

theorem wls_swapEnv_involutive2[simp]:
assumes "wlsEnv rho"
shows "((rho &[x  y]_zs) &[y  x]_zs) = rho"
using assms by(simp add: swapEnv_sym)

theorem wls_swapEnv_preserves_freshEnv[simp]:
assumes "wlsEnv rho"
shows "freshEnv xs (x @xs[y1  y2]_ys) (rho &[y1  y2]_ys) = freshEnv xs x rho"
using assms by simp

theorem wls_swapEnv_preserves_freshEnv_distinct:
assumes "wlsEnv rho"
       "xs  ys  x  {y1,y2}"
shows "freshEnv xs x (rho &[y1  y2]_ys) = freshEnv xs x rho"
using assms by (intro swapEnv_preserves_freshEnv_distinct) auto

theorem wls_freshEnv_swapEnv_exchange1:
assumes "wlsEnv rho"
shows "freshEnv xs x2 (rho &[x1  x2]_xs) = freshEnv xs x1 rho"
using assms by (intro freshEnv_swapEnv_exchange1) auto

theorem wls_freshEnv_swapEnv_exchange2:
assumes "wlsEnv rho"
shows "freshEnv xs x2 (rho &[x2  x1]_xs) = freshEnv xs x1 rho"
using assms by (intro freshEnv_swapEnv_exchange2) auto

theorem wls_freshEnv_swapEnv_id[simp]:
assumes "wlsEnv rho" and "freshEnv xs x1 rho" and "freshEnv xs x2 rho"
shows "(rho &[x1  x2]_xs) = rho"
using assms by simp

theorem wls_freshEnv_swapEnv_compose:
assumes "wlsEnv rho" and "freshEnv xs y rho" and "freshEnv xs z rho"
shows "((rho &[y  x]_xs) &[z  y]_xs) = (rho &[z  x]_xs)"
using assms by (intro freshEnv_swapEnv_compose) auto

subsubsection ‹W.r.t. abstractions›

theorem wls_swapAbs_ident[simp]:
"wlsAbs (us,s) A  (A $[x  x]_xs) = A"
by (elim wlsAbs_cases) auto

theorem wls_swapAbs_compose:
"wlsAbs (us,s) A 
 ((A $[x  y]_zs) $[x'  y']_zs') =
 ((A $[x'  y']_zs') $[(x @zs[x'  y']_zs')  (y @zs[x'  y']_zs')]_zs)"
by (erule wlsAbs_cases) (simp, metis sw_compose wls_swap_compose)

theorem wls_swapAbs_commute:
assumes "zs  zs'  {x,y}  {x',y'} = {}"
shows
"wlsAbs (us,s) A 
 ((A $[x  y]_zs) $[x'  y']_zs') = ((A $[x'  y']_zs') $[x  y]_zs)"
using assms by (elim wlsAbs_cases) (simp add: sw_commute wls_swap_commute)

theorem wls_swapAbs_involutive[simp]:
"wlsAbs (us,s) A  ((A $[x  y]_zs) $[x  y]_zs) = A"
by (erule wlsAbs_cases) simp_all

theorem wls_swapAbs_sym:
"wlsAbs (us,s) A  (A $[x  y]_zs) = (A $[y  x]_zs)"
by (erule wlsAbs_cases) (auto simp add: swap_sym sw_sym)

theorem wls_swapAbs_inj[simp]:
assumes "wlsAbs (us,s) A" and "wlsAbs (us,s) A'"
shows
"((A $[x  y]_zs) = (A' $[x  y]_zs)) =
 (A = A')" 
by (metis assms wls_swapAbs_involutive)

theorem wls_swapAbs_involutive2[simp]:
"wlsAbs (us,s) A  ((A $[x  y]_zs) $[y  x]_zs) = A"
using wls_swapAbs_sym[of us s A zs x y] by auto

theorem wls_swapAbs_preserves_freshAbs[simp]:
"wlsAbs (us,s) A
  freshAbs xs (x @xs[y1  y2]_ys) (A $[y1  y2]_ys) = freshAbs xs x A"
by (erule wlsAbs_cases)   
  (simp_all add: sw_def wls_fresh_swap_exchange1 wls_fresh_swap_exchange2 
wls_swap_preserves_fresh_distinct) 

theorem wls_swapAbs_preserves_freshAbs_distinct:
"wlsAbs (us,s) A; xs  ys  x  {y1,y2}
  freshAbs xs x (A $[y1  y2]_ys) = freshAbs xs x A"
apply(erule wlsAbs_cases) apply simp_all
unfolding sw_def by (auto simp: wls_swap_preserves_fresh_distinct)

theorem wls_freshAbs_swapAbs_exchange1:
"wlsAbs (us,s) A
  freshAbs xs x2 (A $[x1  x2]_xs) = freshAbs xs x1 A"
apply(erule wlsAbs_cases) apply simp_all
unfolding sw_def by (auto simp add: wls_fresh_swap_exchange1)

theorem wls_freshAbs_swapAbs_exchange2:
"wlsAbs (us,s) A
  freshAbs xs x2 (A $[x2  x1]_xs) = freshAbs xs x1 A"
apply(erule wlsAbs_cases) apply simp_all
unfolding sw_def by (auto simp add: wls_fresh_swap_exchange2)

theorem wls_freshAbs_swapAbs_id[simp]:
assumes "wlsAbs (us,s) A"
and "freshAbs xs x1 A" and "freshAbs xs x2 A"
shows "(A $[x1  x2]_xs) = A"
using assms by simp

lemma wls_freshAbs_swapAbs_compose_aux:
"wlsAbs (us,s) A; wlsPar P 
  x y z. {x,y,z}  varsOfS P xs  freshAbs xs y A  freshAbs xs z A 
           ((A $[y  x]_xs) $[z  y]_xs) = (A $[z  x]_xs)"
apply(erule wlsAbs_fresh_cases)  
by simp_all (metis fresh_swap_compose sw_def wls_imp_good) 

theorem wls_freshAbs_swapAbs_compose:
assumes "wlsAbs (us,s) A"
and "freshAbs xs y A"  and "freshAbs xs z A"
shows "((A $[y  x]_xs) $[z  y]_xs) = (A $[z  x]_xs)"
proof-
  let ?P =
  "ParS (λxs'. if xs' = xs then [x,y,z] else []) (λs.[]) (λ_. []) [] ::
  ('index, 'bindex, 'varSort, 'var, 'opSym, 'sort) paramS"
  show ?thesis
  using assms wls_freshAbs_swapAbs_compose_aux[of us s A ?P xs]
  unfolding wlsPar_def by simp
qed

theorem wls_skelAbs_swapAbs:
"wlsAbs (us,s) A
  skelAbs (A $[x1  x2]_xs) = skelAbs A"
by (erule wlsAbs_cases) (auto simp: wls_skel_swap)

lemmas wls_swapAll_freshAll_otherSimps =
wls_swap_ident wls_swap_involutive wls_swap_inj wls_swap_involutive2 wls_swap_preserves_fresh wls_fresh_swap_id

wls_swapAbs_ident wls_swapAbs_involutive wls_swapAbs_inj wls_swapAbs_involutive2 wls_swapAbs_preserves_freshAbs
wls_freshAbs_swapAbs_id

wls_swapEnv_ident wls_swapEnv_involutive wls_swapEnv_inj wls_swapEnv_involutive2 wls_swapEnv_preserves_freshEnv
wls_freshEnv_swapEnv_id

subsection ‹Compositionality properties for the other operators›

subsubsection ‹Environment identity, update and ``get" versus other operators›

(* Recall lemmas getEnv_idEnv, getEnv_updEnv_idEnv, getEnv_updEnv1, getEnv_updEnv2,
subst_psubst_idEnv, vsubst_psubst_idEnv, substEnv_psubstEnv_idEnv, vsubstEnv_psubstEnv_idEnv,
freshEnv_idEnv,
swapEnv_idEnv, psubstEnv_idEnv, substEnv_idEnv, vsubstEnv_idEnv. *)

theorem wls_psubst_idEnv[simp]:
"wls s X  (X #[idEnv]) = X"
by simp

theorem wls_psubstEnv_idEnv_id[simp]:
"wlsEnv rho  (rho &[idEnv]) = rho"
by simp

(* Recall lemmas updEnv_overwrite, updEnv_commute,
   freshEnv_updEnv_E1, freshEnv_updEnv_E2, freshEnv_updEnv_E3, freshEnv_updEnv_E4,
   freshEnv_updEnv_I,
   swapEnv_updEnv *)

theorem wls_swapEnv_updEnv_fresh:
assumes "zs  ys  y  {z1,z2}" and "wls (asSort ys) Y"
and "fresh zs z1 Y" and "fresh zs z2 Y"
shows "((rho [y  Y]_ys) &[z1  z2]_zs) = ((rho &[z1  z2]_zs) [y  Y]_ys)"
using assms by (simp add: swapEnv_updEnv_fresh)

(* Recall lemmas psubstEnv_updEnv, psubstEnv_updEnv_idEnv,
   substEnv_updEnv,  vsubstEnv_updEnv, getEnv_ext *)

(* Recall lemmas freshEnv_getEnv1 freshEnv_getEnv2 freshEnv_getEnv swapEnv_getEnv1 swapEnv_getEnv2
   getEnv_psubstEnv_None getEnv_psubstEnv_Some
   getEnv_substEnv1 getEnv_substEnv2 getEnv_substEnv3 getEnv_substEnv4
   getEnv_vsubstEnv1 getEnv_vsubstEnv2 getEnv_vsubstEnv3 getEnv_vsubstEnv4. *)

subsubsection ‹Substitution versus other operators›

(* Recall definition freshImEnvAt_def. *)

theorem wls_fresh_psubst:
assumes "wls s X" and "wlsEnv rho"
shows
"fresh zs z (X #[rho]) =
 ( ys y. fresh ys y X  freshImEnvAt zs z rho ys y)"
using assms by(simp add: fresh_psubst)

theorem wls_fresh_psubst_E1:
assumes "wls s X" and "wlsEnv rho"
and "rho ys y = None" and "fresh zs z (X #[rho])"
shows "fresh ys y X  (ys  zs  y  z)"
using assms fresh_psubst_E1[of X rho ys y zs z] by simp

theorem wls_fresh_psubst_E2:
assumes "wls s X" and "wlsEnv rho"
and "rho ys y = Some Y" and "fresh zs z (X #[rho])"
shows "fresh ys y X  fresh zs z Y"
using assms fresh_psubst_E2[of X rho ys y Y zs z] by simp

theorem wls_fresh_psubst_I1:
assumes "wls s X" and "wlsEnv rho"
and "fresh zs z X" and "freshEnv zs z rho"
shows "fresh zs z (X #[rho])"
using assms by(simp add: fresh_psubst_I1)

theorem wls_psubstEnv_preserves_freshEnv:
assumes "wlsEnv rho" and "wlsEnv rho'"
and fresh: "freshEnv zs z rho"  "freshEnv zs z rho'"
shows "freshEnv zs z (rho &[rho'])"
using assms by(simp add: psubstEnv_preserves_freshEnv)

theorem wls_fresh_psubst_I:
assumes "wls s X" and "wlsEnv rho"
and "rho zs z = None  fresh zs z X" and
    " ys y Y. rho ys y = Some Y  fresh ys y X  fresh zs z Y"
shows "fresh zs z (X #[rho])"
using assms by(simp add: fresh_psubst_I)

theorem wls_fresh_subst:
assumes "wls s X" and "wls (asSort ys) Y"
shows "fresh zs z (X #[Y / y]_ys) =
       (((zs = ys  z = y)  fresh zs z X)  (fresh ys y X  fresh zs z Y))"
using assms by(simp add: fresh_subst)

theorem wls_fresh_vsubst:
assumes "wls s X"
shows "fresh zs z (X #[y1 // y]_ys) =
       (((zs = ys  z = y)  fresh zs z X)  (fresh ys y X  (zs  ys  z  y1)))"
using assms by(simp add: fresh_vsubst)

theorem wls_subst_preserves_fresh:
assumes "wls s X" and "wls (asSort ys) Y"
and "fresh zs z X" and "fresh zs z Y"
shows "fresh zs z (X #[Y / y]_ys)"
using assms by(simp add: subst_preserves_fresh)

theorem wls_substEnv_preserves_freshEnv:
assumes "wlsEnv rho" and "wls (asSort ys) Y"
and "freshEnv zs z rho" and "fresh zs z Y" and "zs  ys  z  y"
shows "freshEnv zs z (rho &[Y / y]_ys)"
using assms by(simp add: substEnv_preserves_freshEnv)

theorem wls_vsubst_preserves_fresh:
assumes "wls s X"
and "fresh zs z X" and "zs  ys  z  y1"
shows "fresh zs z (X #[y1 // y]_ys)"
using assms by(simp add: vsubst_preserves_fresh)

theorem wls_vsubstEnv_preserves_freshEnv:
assumes "wlsEnv rho"
and "freshEnv zs z rho" and "zs  ys  z  {y,y1}"
shows "freshEnv zs z (rho &[y1 // y]_ys)"
using assms by(simp add: vsubstEnv_preserves_freshEnv)

theorem wls_fresh_fresh_subst[simp]:
assumes "wls (asSort ys) Y" and "wls s  X"
and "fresh ys y Y"
shows "fresh ys y (X #[Y / y]_ys)"
using assms by(simp add: fresh_fresh_subst)

theorem wls_diff_fresh_vsubst[simp]:
assumes "wls s X"
and "y  y1"
shows "fresh ys y (X #[y1 // y]_ys)"
using assms by(simp add: diff_fresh_vsubst)

theorem wls_fresh_subst_E1:
assumes "wls s X" and "wls (asSort ys) Y"
and "fresh zs z (X #[Y / y]_ys)" and "zs  ys  z  y"
shows "fresh zs z X"
using assms fresh_subst_E1[of X Y zs z ys y] by simp

theorem wls_fresh_vsubst_E1:
assumes "wls s X"
and "fresh zs z (X #[y1 // y]_ys)" and "zs  ys  z  y"
shows "fresh zs z X"
using assms fresh_vsubst_E1[of X zs z ys y1 y] by simp

theorem wls_fresh_subst_E2:
assumes "wls s X" and "wls (asSort ys) Y"
and "fresh zs z (X #[Y / y]_ys)"
shows "fresh ys y X  fresh zs z Y"
using assms fresh_subst_E2[of X Y zs z ys y] by simp

theorem wls_fresh_vsubst_E2:
assumes "wls s X"
and "fresh zs z (X #[y1 // y]_ys)"
shows "fresh ys y X  zs  ys  z  y1"
using assms fresh_vsubst_E2[of X zs z ys y1 y] by simp

theorem wls_psubst_cong[fundef_cong]:
assumes "wls s X" and "wlsEnv rho" and "wlsEnv rho'"
and " ys y. fresh ys y X  rho ys y = rho' ys y"
shows "(X #[rho]) = (X #[rho'])"
using assms by (simp add: psubst_cong)

theorem wls_fresh_psubst_updEnv:
assumes "wls (asSort ys) Y" and "wls s X" and "wlsEnv rho"
and "fresh ys y X"
shows "(X #[rho [y  Y]_ys]) = (X #[rho])"
using assms by(simp add: fresh_psubst_updEnv)

theorem wls_freshEnv_psubst_ident[simp]:
assumes "wls s X" and "wlsEnv rho"
and " zs z. freshEnv zs z rho  fresh zs z X"
shows "(X #[rho]) = X"
using assms by simp

theorem wls_fresh_subst_ident[simp]:
assumes "wls (asSort ys) Y" and "wls s X" and "fresh ys y X"
shows "(X #[Y / y]_ys) = X"
using assms by(simp add: fresh_subst_ident)

theorem wls_substEnv_updEnv_fresh:
assumes "wls (asSort xs) X" and "wls (asSort ys) Y" and "fresh ys y X"
shows "((rho [x  X]_xs) &[Y / y]_ys) = ((rho &[Y / y]_ys) [x  X]_xs)"
using assms by(simp add: substEnv_updEnv_fresh)

theorem wls_fresh_substEnv_updEnv[simp]:
assumes "wlsEnv rho" and "wls (asSort ys) Y"
and "freshEnv ys y rho"
shows "(rho &[Y / y]_ys) = (rho [y  Y]_ys)"
using assms by simp

theorem wls_fresh_vsubst_ident[simp]:
assumes "wls s X" and "fresh ys y X"
shows "(X #[y1 // y]_ys) = X"
using assms by(simp add: fresh_vsubst_ident)

theorem wls_vsubstEnv_updEnv_fresh:
assumes "wls s X" and "fresh ys y X"
shows "((rho [x  X]_xs) &[y1 // y]_ys) = ((rho &[y1 // y]_ys) [x  X]_xs)"
using assms by(simp add: vsubstEnv_updEnv_fresh)

theorem wls_fresh_vsubstEnv_updEnv[simp]:
assumes "wlsEnv rho"
and "freshEnv ys y rho"
shows "(rho &[y1 // y]_ys) = (rho [y  Var ys y1]_ys)"
using assms by simp

theorem wls_swap_psubst:
assumes "wls s X" and "wlsEnv rho"
shows "((X #[rho]) #[z1  z2]_zs) = ((X #[z1  z2]_zs) #[rho &[z1  z2]_zs])"
using assms by(simp add: swap_psubst)

theorem wls_swap_subst:
assumes "wls s  X" and "wls (asSort ys) Y"
shows "((X #[Y / y]_ys) #[z1  z2]_zs) = ((X #[z1  z2]_zs) #[(Y #[z1  z2]_zs) / (y @ys[z1  z2]_zs)]_ys)"
using assms by(simp add: swap_subst)

theorem wls_swap_vsubst:
assumes "wls s X"
shows "((X #[y1 // y]_ys) #[z1  z2]_zs) = ((X #[z1  z2]_zs) #[(y1 @ys[z1  z2]_zs) // (y @ys[z1  z2]_zs)]_ys)"
using assms by(simp add: swap_vsubst)

theorem wls_swapEnv_psubstEnv:
assumes "wlsEnv rho" and "wlsEnv rho'"
shows "((rho &[rho']) &[z1  z2]_zs) = ((rho &[z1  z2]_zs) &[rho' &[z1  z2]_zs])"
using assms by(simp add: swapEnv_psubstEnv)

theorem wls_swapEnv_substEnv:
assumes "wls (asSort ys) Y" and "wlsEnv rho"
shows "((rho &[Y / y]_ys) &[z1  z2]_zs) =
       ((rho &[z1  z2]_zs) &[(Y #[z1  z2]_zs) / (y @ys[z1  z2]_zs)]_ys)"
using assms by(simp add: swapEnv_substEnv)

theorem wls_swapEnv_vsubstEnv:
assumes "wlsEnv rho"
shows "((rho &[y1 // y]_ys) &[z1  z2]_zs) =
       ((rho &[z1  z2]_zs) &[(y1 @ys[z1  z2]_zs) // (y @ys[z1  z2]_zs)]_ys)"
using assms by(simp add: swapEnv_vsubstEnv)

theorem wls_psubst_compose:
assumes "wls s X" and "wlsEnv rho" and "wlsEnv rho'"
shows "((X #[rho]) #[rho']) = (X #[(rho &[rho'])])"
using assms by(simp add: psubst_compose)

theorem wls_psubstEnv_compose:
assumes "wlsEnv rho" and "wlsEnv rho'" and "wlsEnv rho''"
shows "((rho &[rho']) &[rho'']) = (rho &[(rho' &[rho''])])"
using assms by(simp add: psubstEnv_compose)

theorem wls_psubst_subst_compose:
assumes "wls s X" and "wls (asSort ys) Y" and "wlsEnv rho"
shows "((X #[Y / y]_ys) #[rho]) = (X #[(rho [y  (Y #[rho])]_ys)])"
using assms by(simp add: psubst_subst_compose)

theorem wls_psubst_subst_compose_freshEnv:
assumes "wlsEnv rho" and "wls s X" and "wls (asSort ys) Y"
and "freshEnv ys y rho"
shows "((X #[Y / y]_ys) #[rho]) = ((X #[rho]) #[(Y #[rho]) / y]_ys)"
using assms by (simp add: psubst_subst_compose_freshEnv)

theorem wls_psubstEnv_substEnv_compose_freshEnv:
assumes "wlsEnv rho" and "wlsEnv rho'" and "wls (asSort ys) Y"
assumes "freshEnv ys y rho'"
shows "((rho &[Y / y]_ys) &[rho']) = ((rho &[rho']) &[(Y #[rho']) / y]_ys)"
using assms by (simp add: psubstEnv_substEnv_compose_freshEnv)

theorem wls_psubstEnv_substEnv_compose:
assumes "wlsEnv rho" and "wls (asSort ys) Y" and "wlsEnv rho'"
shows "((rho &[Y / y]_ys) &[rho']) = (rho &[(rho' [y  (Y #[rho'])]_ys)])"
using assms by(simp add: psubstEnv_substEnv_compose)

theorem wls_psubst_vsubst_compose:
assumes "wls s X" and "wlsEnv rho"
shows "((X #[y1 // y]_ys) #[rho]) = (X #[(rho [y  ((Var ys y1) #[rho])]_ys)])"
using assms by(simp add: psubst_vsubst_compose)

theorem wls_psubstEnv_vsubstEnv_compose:
assumes "wlsEnv rho" and "wlsEnv rho'"
shows "((rho &[y1 // y]_ys) &[rho']) = (rho &[(rho' [y  ((Var ys y1) #[rho'])]_ys)])"
using assms by(simp add: psubstEnv_vsubstEnv_compose)

theorem wls_subst_psubst_compose:
assumes "wls s X" and "wls (asSort ys) Y" and "wlsEnv rho"
shows "((X #[rho]) #[Y / y]_ys) = (X #[(rho &[Y / y]_ys)])"
using assms by(simp add: subst_psubst_compose)

theorem wls_substEnv_psubstEnv_compose:
assumes "wlsEnv rho" and "wls (asSort ys) Y" and "wlsEnv rho'"
shows "((rho &[rho']) &[Y / y]_ys) = (rho &[(rho' &[Y / y]_ys)])"
using assms by(simp add: substEnv_psubstEnv_compose)

theorem wls_vsubst_psubst_compose:
assumes "wls s X" and "wlsEnv rho"
shows "((X #[rho]) #[y1 // y]_ys) = (X #[(rho &[y1 // y]_ys)])"
using assms by(simp add: vsubst_psubst_compose)

theorem wls_vsubstEnv_psubstEnv_compose:
assumes "wlsEnv rho" and "wlsEnv rho'"
shows "((rho &[rho']) &[y1 // y]_ys) = (rho &[(rho' &[y1 // y]_ys)])"
using assms by(simp add: vsubstEnv_psubstEnv_compose)

theorem wls_subst_compose1:
assumes "wls s X" and "wls (asSort ys) Y1" and "wls (asSort ys) Y2"
shows "((X #[Y1 / y]_ys) #[Y2 / y]_ys) = (X #[(Y1 #[Y2 / y]_ys) / y]_ys)"
using assms by(simp add: subst_compose1)

theorem wls_substEnv_compose1:
assumes "wlsEnv rho" and "wls (asSort ys) Y1" and "wls (asSort ys) Y2"
shows "((rho &[Y1 / y]_ys) &[Y2 / y]_ys) = (rho &[(Y1 #[Y2 / y]_ys) / y]_ys)"
using assms by(simp add: substEnv_compose1)

theorem wls_subst_vsubst_compose1:
assumes "wls s X" and "wls (asSort ys) Y" and "y  y1"
shows "((X #[y1 // y]_ys) #[Y / y]_ys) = (X #[y1 // y]_ys)"
using assms by(simp add: subst_vsubst_compose1)

theorem wls_substEnv_vsubstEnv_compose1:
assumes "wlsEnv rho" and "wls (asSort ys) Y" and "y  y1"
shows "((rho &[y1 // y]_ys) &[Y / y]_ys) = (rho &[y1 // y]_ys)"
using assms by(simp add: substEnv_vsubstEnv_compose1)

theorem wls_vsubst_subst_compose1:
assumes "wls s X" and "wls (asSort ys) Y"
shows "((X #[Y / y]_ys) #[y1 // y]_ys) = (X #[(Y #[y1 // y]_ys) / y]_ys)"
using assms by(simp add: vsubst_subst_compose1)

theorem wls_vsubstEnv_substEnv_compose1:
assumes "wlsEnv rho" and "wls (asSort ys) Y"
shows "((rho &[Y / y]_ys) &[y1 // y]_ys) = (rho &[(Y #[y1 // y]_ys) / y]_ys)"
using assms by(simp add: vsubstEnv_substEnv_compose1)

theorem wls_vsubst_compose1:
assumes "wls s X"
shows "((X #[y1 // y]_ys) #[y2 // y]_ys) = (X #[(y1 @ys[y2 / y]_ys) // y]_ys)"
using assms by(simp add: vsubst_compose1)

theorem wls_vsubstEnv_compose1:
assumes "wlsEnv rho"
shows "((rho &[y1 // y]_ys) &[y2 // y]_ys) = (rho &[(y1 @ys[y2 / y]_ys) // y]_ys)"
using assms by(simp add: vsubstEnv_compose1)

theorem wls_subst_compose2:
assumes  "wls s X" and "wls (asSort ys) Y" and "wls (asSort zs) Z"
and "ys  zs  y  z" and fresh: "fresh ys y Z"
shows "((X #[Y / y]_ys) #[Z / z]_zs) = ((X #[Z / z]_zs) #[(Y #[Z / z]_zs) / y]_ys)"
using assms by(simp add: subst_compose2)

theorem wls_substEnv_compose2:
assumes  "wlsEnv rho" and "wls (asSort ys) Y" and "wls (asSort zs) Z"
and "ys  zs  y  z" and fresh: "fresh ys y Z"
shows "((rho &[Y / y]_ys) &[Z / z]_zs) = ((rho &[Z / z]_zs) &[(Y #[Z / z]_zs) / y]_ys)"
using assms by(simp add: substEnv_compose2)

theorem wls_subst_vsubst_compose2:
assumes  "wls s X" and "wls (asSort zs) Z"
and "ys  zs  y  z" and fresh: "fresh ys y Z"
shows "((X #[y1 // y]_ys) #[Z / z]_zs) = ((X #[Z / z]_zs) #[((Var ys y1) #[Z / z]_zs) / y]_ys)"
using assms by(simp add: subst_vsubst_compose2)

theorem wls_substEnv_vsubstEnv_compose2:
assumes  "wlsEnv rho" and "wls (asSort zs) Z"
and "ys  zs  y  z" and fresh: "fresh ys y Z"
shows "((rho &[y1 // y]_ys) &[Z / z]_zs) = ((rho &[Z / z]_zs) &[((Var ys y1) #[Z / z]_zs) / y]_ys)"
using assms by(simp add: substEnv_vsubstEnv_compose2)

theorem wls_vsubst_subst_compose2:
assumes  "wls s X" and "wls (asSort ys) Y"
and "ys  zs  y  {z,z1}"
shows "((X #[Y / y]_ys) #[z1 // z]_zs) = ((X #[z1 // z]_zs) #[(Y #[z1 // z]_zs) / y]_ys)"
using assms by(simp add: vsubst_subst_compose2)

theorem wls_vsubstEnv_substEnv_compose2:
assumes  "wlsEnv rho" and "wls (asSort ys) Y"
and "ys  zs  y  {z,z1}"
shows "((rho &[Y / y]_ys) &[z1 // z]_zs) = ((rho &[z1 // z]_zs) &[(Y #[z1 // z]_zs) / y]_ys)"
using assms by(simp add: vsubstEnv_substEnv_compose2)

theorem wls_vsubst_compose2:
assumes  "wls s X"
and "ys  zs  y  {z,z1}"
shows "((X #[y1 // y]_ys) #[z1 // z]_zs) = ((X #[z1 // z]_zs) #[(y1 @ys[z1 / z]_zs) // y]_ys)"
using assms by(simp add: vsubst_compose2)

theorem wls_vsubstEnv_compose2:
assumes  "wlsEnv rho"
and "ys  zs  y  {z,z1}"
shows "((rho &[y1 // y]_ys) &[z1 // z]_zs) =
       ((rho &[z1 // z]_zs) &[(y1 @ys[z1 / z]_zs) // y]_ys)"
using assms by(simp add: vsubstEnv_compose2)

subsubsection ‹Properties specific to variable-for-variable substitution›

theorem wls_vsubst_ident[simp]:
assumes "wls s X"
shows "(X #[z // z]_zs) = X"
using assms by(simp add: vsubst_ident)

theorem wls_subst_ident[simp]:
assumes "wls s  X"
shows "(X #[(Var zs z) / z]_zs) = X"
using assms by simp

theorem wls_vsubst_eq_swap:
assumes "wls s X" and "y1 = y2  fresh ys y1 X"
shows "(X #[y1 // y2]_ys) = (X #[y1  y2]_ys)"
using assms by(simp add: vsubst_eq_swap)

theorem wls_skel_vsubst:
assumes "wls s X"
shows "skel (X #[y1 // y2]_ys) = skel X"
using assms by(simp add: skel_vsubst)

theorem wls_subst_vsubst_trans:
assumes  "wls s X" and "wls (asSort ys) Y" and "fresh ys y1 X"
shows "((X #[y1 // y]_ys) #[Y / y1]_ys) = (X #[Y / y]_ys)"
using assms by (simp add: subst_vsubst_trans)

theorem wls_vsubst_trans:
assumes  "wls s X" and "fresh ys y1 X"
shows "((X #[y1 // y]_ys) #[y2 // y1]_ys) = (X #[y2 // y]_ys)"
using assms by (simp add: vsubst_trans)

theorem wls_vsubst_commute:
assumes "wls s X"
and "xs  xs'  {x,y}  {x',y'} = {}" and "fresh xs x X" and "fresh xs' x' X"
shows "((X #[x // y]_xs) #[x' // y']_xs') = ((X #[x' // y']_xs') #[x // y]_xs)"
using assms by(simp add: vsubst_commute)

(* The next lemmas do not have ``good" counterparts: *)

theorem wls_induct[case_names Var Op Abs]:
assumes
Var: " xs x. phi (asSort xs) (Var xs x)" and
Op:
" delta inp binp.
   wlsInp delta inp; wlsBinp delta binp;
    liftAll2 phi (arOf delta) inp; liftAll2 phiAbs (barOf delta) binp
    phi (stOf delta) (Op delta inp binp)" and
Abs:
" s xs x X.
   isInBar (xs,s); wls s X;
     Y. (X,Y)  swapped  phi s Y;
     ys y1 y2. phi s (X #[y1 // y2]_ys);
     Y. wls s Y; skel Y = skel X  phi s Y
    phiAbs (xs,s) (Abs xs x X)"
shows
"(wls s X  phi s X) 
 (wlsAbs (xs,s') A  phiAbs (xs,s') A)"
apply(induction rule: wls_templateInduct
[of "λs. swapped  {(X, X #[y1 // y2]_ys)| X ys y1 y2. True}
          {(X,Y). wls s Y  skel Y = skel X}"])
by (auto simp add: assms swapped_preserves_wls swapped_skel wls_skel_vsubst 
   intro!: Abs) 

theorem wls_Abs_vsubst_all_aux:
assumes "wls s X" and "wls s X'"
shows
"(Abs xs x X = Abs xs x' X') =
 ( y. (y = x  fresh xs y X)  (y = x'  fresh xs y X') 
       (X #[y // x]_xs) = (X' #[y // x']_xs))"
using assms wls_Abs_swap_all by (simp add: wls_vsubst_eq_swap)

theorem wls_Abs_vsubst_ex:
assumes  "wls s X" and "wls s X'"
shows
"(Abs xs x X = Abs xs x' X') =
 ( y. y  {x,x'}  fresh xs y X  fresh xs y X' 
       (X #[y // x]_xs) = (X' #[y // x']_xs))"
proof-
  let ?phi = "λ f y. y  {x,x'}  fresh xs y X  fresh xs y X'
                      (f xs y x X) = (f xs y x' X')"
  {assume "Abs xs x X = Abs xs x' X'"
   then obtain y where "?phi swap y" using assms wls_Abs_swap_ex by auto
   hence "?phi (λ xs y x X. (X #[y // x]_xs)) y"
   using assms by(simp add: wls_vsubst_eq_swap)
   hence " y. ?phi (λ xs y x X. (X #[y // x]_xs)) y" by auto
  }
  moreover
  {fix y assume  "?phi (λ xs y x X. (X #[y // x]_xs)) y"
   hence "?phi swap y" using assms by(auto simp add: wls_vsubst_eq_swap)
   hence "Abs xs x X = Abs xs x' X'" using assms wls_Abs_swap_ex by auto
  }
  ultimately show ?thesis by auto
qed

theorem wls_Abs_vsubst_all:
assumes "wls s X" and "wls s X'"
shows
"(Abs xs x X = Abs xs x' X') =
 ( y. (X #[y // x]_xs) = (X' #[y // x']_xs))"
proof(rule iffI, clarify)
  assume " y. (X #[y // x]_xs) = (X' #[y // x']_xs)"
  thus "Abs xs x X = Abs xs x' X'"
  using assms by(auto simp add: wls_Abs_vsubst_all_aux)
next
  fix y
  assume "Abs xs x X = Abs xs x' X'"
  then obtain z where z_fresh: "fresh xs z X  fresh xs z X'"
  and "(X #[z // x]_xs) = (X' #[z // x']_xs)"
  using assms by(auto simp add: wls_Abs_vsubst_ex)
  hence "((X #[z // x]_xs) #[y // z]_xs) = ((X' #[z // x']_xs) #[y // z]_xs)" by simp
  thus "(X #[y // x]_xs) = (X' #[y // x']_xs)"
  using assms z_fresh wls_vsubst_trans by auto
qed

theorem wls_Abs_subst_all:
assumes "wls s X" and "wls s X'"
shows
"(Abs xs x X = Abs xs x' X') =
 ( Y. wls (asSort xs) Y  (X #[Y / x]_xs) = (X' #[Y / x']_xs))"
proof(rule iffI, clarify)
  assume " Y. wls (asSort xs) Y  (X #[Y / x]_xs) = (X' #[Y / x']_xs)"
  hence " y. (X #[y // x]_xs) = (X' #[y // x']_xs)"
  unfolding vsubst_def by simp
  thus "Abs xs x X = Abs xs x' X'"
  using assms wls_Abs_vsubst_all by auto
next
  fix Y assume Y: "wls (asSort xs) Y"
  assume "Abs xs x X = Abs xs x' X'"
  then obtain z where z_fresh: "fresh xs z X  fresh xs z X'"
  and "(X #[z // x]_xs) = (X' #[z // x']_xs)"
  using assms by(auto simp add: wls_Abs_vsubst_ex)
  hence "((X #[z // x]_xs) #[Y / z]_xs) = ((X' #[z // x']_xs) #[Y / z]_xs)" by simp
  thus "(X #[Y / x]_xs) = (X' #[Y / x']_xs)"
  using assms z_fresh Y wls_subst_vsubst_trans by auto
qed

lemma Abs_inj_fresh[simp]:
assumes X: "wls s X" and X': "wls s X'"
and fresh_X: "fresh ys x X" and fresh_X': "fresh ys x' X'"
and eq: "Abs ys x X = Abs ys x' X'"
shows "X = X'"
proof-
  obtain z where "(X #[z // x]_ys) = (X' #[z // x']_ys)"
  using X X' eq by(auto simp add: wls_Abs_vsubst_ex)
  thus ?thesis using X X' fresh_X fresh_X' by simp
qed

theorem wls_Abs_vsubst_cong:
assumes "wls s X" and "wls s X'"
and "fresh xs y X" and "fresh xs y X'"  and "(X #[y // x]_xs) = (X' #[y // x']_xs)"
shows "Abs xs x X = Abs xs x' X'"
using assms by (intro wls_Abs_swap_cong) (auto simp: wls_vsubst_eq_swap)

theorem wls_Abs_vsubst_fresh[simp]:
assumes "wls s X" and "fresh xs x' X"
shows "Abs xs x' (X #[x' // x]_xs) = Abs xs x X"
using assms by(simp add: wls_vsubst_eq_swap)

theorem wls_Abs_subst_Var_fresh[simp]:
assumes "wls s X" and "fresh xs x' X"
shows "Abs xs x' (subst xs (Var xs x') x X) = Abs xs x X"
using assms wls_Abs_vsubst_fresh unfolding vsubst_def by simp

theorem wls_Abs_vsubst_congSTR:
assumes "wls s X" and "wls s X'"
and "y = x  fresh xs y X" "y = x'  fresh xs y X'"
and "(X #[y // x]_xs) = (X' #[y // x']_xs)"
shows "Abs xs x X = Abs xs x' X'"
by (metis assms wls_Abs_vsubst_fresh wls_vsubst_ident)

subsubsection ‹Abstraction versions of the properties›

(* Environment identity and update versus other operators *)

theorem wls_psubstAbs_idEnv[simp]:
"wlsAbs (us,s) A  (A $[idEnv]) = A"
by simp

(* Substitution versus other operators  *)

theorem wls_freshAbs_psubstAbs:
assumes "wlsAbs (us,s) A" and "wlsEnv rho"
shows
"freshAbs zs z (A $[rho]) =
 ( ys y. freshAbs ys y A  freshImEnvAt zs z rho ys y)"
using assms by(simp add: freshAbs_psubstAbs)

theorem wls_freshAbs_psubstAbs_E1:
assumes "wlsAbs (us,s) A" and "wlsEnv rho"
and "rho ys y = None" and "freshAbs zs z (A $[rho])"
shows "freshAbs ys y A  (ys  zs  y  z)"
using assms freshAbs_psubstAbs_E1[of A rho ys y zs z] by simp

theorem wls_freshAbs_psubstAbs_E2:
assumes "wlsAbs (us,s) A" and "wlsEnv rho"
and "rho ys y = Some Y" and "freshAbs zs z (A $[rho])"
shows "freshAbs ys y A  fresh zs z Y"
using assms freshAbs_psubstAbs_E2[of A rho ys y Y zs z] by simp

theorem wls_freshAbs_psubstAbs_I1:
assumes "wlsAbs (us,s) A" and "wlsEnv rho"
and "freshAbs zs z A" and "freshEnv zs z rho"
shows "freshAbs zs z (A $[rho])"
using assms by(simp add: freshAbs_psubstAbs_I1)

theorem wls_freshAbs_psubstAbs_I:
assumes "wlsAbs (us,s) A" and "wlsEnv rho"
and "rho zs z = None  freshAbs zs z A" and
    " ys y Y. rho ys y = Some Y  freshAbs ys y A  fresh zs z Y"
shows "freshAbs zs z (A $[rho])"
using assms by(simp add: freshAbs_psubstAbs_I)

theorem wls_freshAbs_substAbs:
assumes "wlsAbs (us,s) A" and "wls (asSort ys) Y"
shows "freshAbs zs z (A $[Y / y]_ys) =
       (((zs = ys  z = y)  freshAbs zs z A)  (freshAbs ys y A  fresh zs z Y))"
using assms by(simp add: freshAbs_substAbs)

theorem wls_freshAbs_vsubstAbs:
assumes "wlsAbs (us,s) A"
shows "freshAbs zs z (A $[y1 // y]_ys) =
       (((zs = ys  z = y)  freshAbs zs z A) 
        (freshAbs ys y A  (zs  ys  z  y1)))"
using assms by(simp add: freshAbs_vsubstAbs)

theorem wls_substAbs_preserves_freshAbs:
assumes "wlsAbs (us,s) A" and "wls (asSort ys) Y"
and "freshAbs zs z A" and "fresh zs z Y"
shows "freshAbs zs z (A $[Y / y]_ys)"
using assms by(simp add: substAbs_preserves_freshAbs)

theorem wls_vsubstAbs_preserves_freshAbs:
assumes "wlsAbs (us,s) A"
and "freshAbs zs z A" and "zs  ys  z  y1"
shows "freshAbs zs z (A $[y1 // y]_ys)"
using assms by(simp add: vsubstAbs_preserves_freshAbs)

theorem wls_fresh_freshAbs_substAbs[simp]:
assumes "wls (asSort ys) Y" and "wlsAbs (us,s) A"
and "fresh ys y Y"
shows "freshAbs ys y (A $[Y / y]_ys)"
using assms by simp

theorem wls_diff_freshAbs_vsubstAbs[simp]:
assumes "wlsAbs (us,s) A"
and "y  y1"
shows "freshAbs ys y (A $[y1 // y]_ys)"
using assms by simp

theorem wls_freshAbs_substAbs_E1:
assumes "wlsAbs (us,s) A" and "wls (asSort ys) Y"
and "freshAbs zs z (A $[Y / y]_ys)" and "z  y  zs  ys"
shows "freshAbs zs z A"
using assms freshAbs_substAbs_E1[of A Y zs z ys y] by auto

theorem wls_freshAbs_vsubstAbs_E1:
assumes "wlsAbs (us,s) A"
and "freshAbs zs z (A $[y1 // y]_ys)" and "z  y  zs  ys"
shows "freshAbs zs z A"
using assms freshAbs_vsubstAbs_E1[of A zs z ys y1 y] by auto

theorem wls_freshAbs_substAbs_E2:
assumes "wlsAbs (us,s) A" and "wls (asSort ys) Y"
and "freshAbs zs z (A $[Y / y]_ys)"
shows "freshAbs ys y A  fresh zs z Y"
using assms freshAbs_substAbs_E2[of A Y zs z ys] by simp

theorem wls_freshAbs_vsubstAbs_E2:
assumes "wlsAbs (us,s) A"
and "freshAbs zs z (A $[y1 // y]_ys)"
shows "freshAbs ys y A  zs  ys  z  y1"
using assms freshAbs_vsubstAbs_E2[of A zs z ys y1 y] by simp

theorem wls_psubstAbs_cong[fundef_cong]:
assumes "wlsAbs (us,s) A" and "wlsEnv rho" and "wlsEnv rho'"
and " ys y. freshAbs ys y A  rho ys y = rho' ys y"
shows "(A $[rho]) = (A $[rho'])"
using assms by(simp add: psubstAbs_cong)

theorem wls_freshAbs_psubstAbs_updEnv:
assumes "wls (asSort xs) X" and "wlsAbs (us,s) A" and "wlsEnv rho"
and "freshAbs xs x A"
shows "(A $[rho [x  X]_xs]) = (A $[rho])"
using assms by(simp add: freshAbs_psubstAbs_updEnv)

lemma wls_freshEnv_psubstAbs_ident[simp]:
assumes "wlsAbs (us,s) A" and "wlsEnv rho"
and " zs z. freshEnv zs z rho  freshAbs zs z A"
shows "(A $[rho]) = A"
using assms by simp

theorem wls_freshAbs_substAbs_ident[simp]:
assumes "wls (asSort xs) X" and "wlsAbs (us,s) A" and "freshAbs xs x A"
shows "(A $[X / x]_xs) = A"
using assms by simp

theorem wls_substAbs_Abs[simp]:
assumes "wls s X" and "wls (asSort xs) Y"
shows "((Abs xs x X) $[Y / x]_xs) = Abs xs x X"
using assms by simp

theorem wls_freshAbs_vsubstAbs_ident[simp]:
assumes "wlsAbs (us,s) A" and "freshAbs xs x A"
shows "(A $[x1 // x]_xs) = A"
using assms by(simp add: freshAbs_vsubstAbs_ident)

theorem wls_swapAbs_psubstAbs:
assumes "wlsAbs (us,s) A" and "wlsEnv rho"
shows "((A $[rho]) $[z1  z2]_zs) = ((A $[z1  z2]_zs) $[rho &[z1  z2]_zs])"
using assms by(simp add: swapAbs_psubstAbs)

theorem wls_swapAbs_substAbs:
assumes "wlsAbs (us,s) A" and "wls (asSort ys) Y"
shows "((A $[Y / y]_ys) $[z1  z2]_zs) =
       ((A $[z1  z2]_zs) $[(Y #[z1  z2]_zs) / (y @ys[z1  z2]_zs)]_ys)"
using assms by(simp add: swapAbs_substAbs)

theorem wls_swapAbs_vsubstAbs:
assumes "wlsAbs (us,s) A"
shows "((A $[y1 // y]_ys) $[z1  z2]_zs) =
       ((A $[z1  z2]_zs) $[(y1 @ys[z1  z2]_zs) // (y @ys[z1  z2]_zs)]_ys)"
using assms by(simp add: swapAbs_vsubstAbs)

theorem wls_psubstAbs_compose:
assumes "wlsAbs (us,s) A" and "wlsEnv rho" and "wlsEnv rho'"
shows "((A $[rho]) $[rho']) = (A $[(rho &[rho'])])"
using assms by(simp add: psubstAbs_compose)

theorem wls_psubstAbs_substAbs_compose:
assumes "wlsAbs (us,s) A" and "wls (asSort ys) Y" and "wlsEnv rho"
shows "((A $[Y / y]_ys) $[rho]) = (A $[(rho [y  (Y #[rho])]_ys)])"
using assms by(simp add: psubstAbs_substAbs_compose)

theorem wls_psubstAbs_substAbs_compose_freshEnv:
assumes "wlsEnv rho" and "wlsAbs (us,s) A" and "wls (asSort ys) Y"
assumes "freshEnv ys y rho"
shows "((A $[Y / y]_ys) $[rho]) = ((A $[rho]) $[(Y #[rho]) / y]_ys)"
using assms by (simp add: psubstAbs_substAbs_compose_freshEnv)

theorem wls_psubstAbs_vsubstAbs_compose:
assumes "wlsAbs (us,s) A" and "wlsEnv rho"
shows "((A $[y1 // y]_ys) $[rho]) = (A $[(rho [y  ((Var ys y1) #[rho])]_ys)])"
using assms by(simp add: psubstAbs_vsubstAbs_compose)

theorem wls_substAbs_psubstAbs_compose:
assumes "wlsAbs (us,s) A" and "wls (asSort ys) Y" and "wlsEnv rho"
shows "((A $[rho]) $[Y / y]_ys) = (A $[(rho &[Y / y]_ys)])"
using assms by(simp add: substAbs_psubstAbs_compose)

theorem wls_vsubstAbs_psubstAbs_compose:
assumes "wlsAbs (us,s) A" and "wlsEnv rho"
shows "((A $[rho]) $[y1 // y]_ys) = (A $[(rho &[y1 // y]_ys)])"
using assms by(simp add: vsubstAbs_psubstAbs_compose)

theorem wls_substAbs_compose1:
assumes "wlsAbs (us,s) A" and "wls (asSort ys) Y1" and "wls (asSort ys) Y2"
shows "((A $[Y1 / y]_ys) $[Y2 / y]_ys) = (A $[(Y1 #[Y2 / y]_ys) / y]_ys)"
using assms by(simp add: substAbs_compose1)

theorem wls_substAbs_vsubstAbs_compose1:
assumes "wlsAbs (us,s) A" and "wls (asSort ys) Y" and "y  y1"
shows "((A $[y1 // y]_ys) $[Y / y]_ys) = (A $[y1 // y]_ys)"
using assms by(simp add: substAbs_vsubstAbs_compose1)

theorem wls_vsubstAbs_substAbs_compose1:
assumes "wlsAbs (us,s) A" and "wls (asSort ys) Y"
shows "((A $[Y / y]_ys) $[y1 // y]_ys) = (A $[(Y #[y1 // y]_ys) / y]_ys)"
using assms by(simp add: vsubstAbs_substAbs_compose1)

theorem wls_vsubstAbs_compose1:
assumes "wlsAbs (us,s) A"
shows "((A $[y1 // y]_ys) $[y2 // y]_ys) = (A $[(y1 @ys[y2 / y]_ys) // y]_ys)"
using assms by(simp add: vsubstAbs_compose1)

theorem wls_substAbs_compose2:
assumes  "wlsAbs (us,s) A" and "wls (asSort ys) Y" and "wls (asSort zs) Z"
and "ys  zs  y  z" and fresh: "fresh ys y Z"
shows "((A $[Y / y]_ys) $[Z / z]_zs) = ((A $[Z / z]_zs) $[(Y #[Z / z]_zs) / y]_ys)"
using assms by(simp add: substAbs_compose2)

theorem wls_substAbs_vsubstAbs_compose2:
assumes "wlsAbs (us,s) A" and "wls (asSort zs) Z"
and "ys  zs  y  z" and fresh: "fresh ys y Z"
shows "((A $[y1 // y]_ys) $[Z / z]_zs) = ((A $[Z / z]_zs) $[((Var ys y1) #[Z / z]_zs) / y]_ys)"
using assms by(simp add: substAbs_vsubstAbs_compose2)

theorem wls_vsubstAbs_substAbs_compose2:
assumes "wlsAbs (us,s) A" and "wls (asSort ys) Y"
and "ys  zs  y  {z,z1}"
shows "((A $[Y / y]_ys) $[z1 // z]_zs) = ((A $[z1 // z]_zs) $[(Y #[z1 // z]_zs) / y]_ys)"
using assms by(simp add: vsubstAbs_substAbs_compose2)

theorem wls_vsubstAbs_compose2:
assumes  "wlsAbs (us,s) A"
and "ys  zs  y  {z,z1}"
shows "((A $[y1 // y]_ys) $[z1 // z]_zs) = ((A $[z1 // z]_zs) $[(y1 @ys[z1 / z]_zs) // y]_ys)"
using assms by(simp add: vsubstAbs_compose2)

(* Properties specific to variable-for-variable substitution *)

theorem wls_vsubstAbs_ident[simp]:
assumes "wlsAbs (us,s) A"
shows "(A $[z // z]_zs) = A"
using assms by(simp add: vsubstAbs_ident)

theorem wls_substAbs_ident[simp]:
assumes "wlsAbs (us,s) A"
shows "(A $[(Var zs z) / z]_zs) = A"
using assms by simp

theorem wls_vsubstAbs_eq_swapAbs:
assumes "wlsAbs (us,s) A" and "y1 = y2  freshAbs ys y1 A"
shows "(A $[y1 // y2]_ys) = (A $[y1  y2]_ys)" 
using assms vsubstAll_swapAll[of "Par [y1, y2] [] [] []" _ _ A]
unfolding goodPar_def by auto

theorem wls_skelAbs_vsubstAbs:
assumes "wlsAbs (us,s) A"
shows "skelAbs (A $[y1 // y2]_ys) = skelAbs A"
using assms by(simp add: skelAbs_vsubstAbs)

theorem wls_substAbs_vsubstAbs_trans:
assumes "wlsAbs (us,s) A" and "wls (asSort ys) Y" and "freshAbs ys y1 A"
shows "((A $[y1 // y]_ys) $[Y / y1]_ys) = (A $[Y / y]_ys)"
using assms by(simp add: substAbs_vsubstAbs_trans)

theorem wls_vsubstAbs_trans:
assumes "wlsAbs (us,s) A" and "freshAbs ys y1 A"
shows "((A $[y1 // y]_ys) $[y2 // y1]_ys) = (A $[y2 // y]_ys)"
using assms by(simp add: vsubstAbs_trans)

theorem wls_vsubstAbs_commute:
assumes "wlsAbs (us,s) A"
and "xs  xs'  {x,y}  {x',y'} = {}" and "freshAbs xs x A" and "freshAbs xs' x' A"
shows "((A $[x // y]_xs) $[x' // y']_xs') = ((A $[x' // y']_xs') $[x // y]_xs)"
proof-
  have "freshAbs xs' x' (A $[x // y]_xs)"
  using assms by(auto simp: vsubstAbs_preserves_freshAbs)
  moreover have "freshAbs xs x (A $[x' // y']_xs')"
  using assms by(auto simp: vsubstAbs_preserves_freshAbs)
  ultimately show ?thesis using assms 
  by (auto simp: vsubstAbs_eq_swapAbs intro!: wls_swapAbs_commute)
qed

lemmas wls_psubstAll_freshAll_otherSimps =
wls_psubst_idEnv wls_psubstEnv_idEnv_id wls_psubstAbs_idEnv
wls_freshEnv_psubst_ident wls_freshEnv_psubstAbs_ident

lemmas wls_substAll_freshAll_otherSimps =
wls_fresh_fresh_subst wls_fresh_subst_ident wls_fresh_substEnv_updEnv wls_subst_ident
wls_fresh_freshAbs_substAbs wls_freshAbs_substAbs_ident wls_substAbs_ident
wls_Abs_subst_Var_fresh

lemmas wls_vsubstAll_freshAll_otherSimps =
wls_diff_fresh_vsubst wls_fresh_vsubst_ident wls_fresh_vsubstEnv_updEnv wls_vsubst_ident
wls_diff_freshAbs_vsubstAbs wls_freshAbs_vsubstAbs_ident wls_vsubstAbs_ident
wls_Abs_vsubst_fresh

lemmas wls_allOpers_otherSimps =
wls_swapAll_freshAll_otherSimps
wls_psubstAll_freshAll_otherSimps
wls_substAll_freshAll_otherSimps
wls_vsubstAll_freshAll_otherSimps

subsection ‹Operators for down-casting and case-analyzing well-sorted items›

text‹The features developed here may occasionally turn out more convenient than obtaining
the desired effect by hand, via the corresponding nchotomies.
E.g., when we want to perform the case-analysis uniformly, as part of a
function definition, the operators defined in the subsection save some tedious
definitions and proofs pertaining to Hilbert choice.›

subsubsection ‹For terms›

(* Definitions: *)

definition isVar where
"isVar s (X :: ('index,'bindex,'varSort,'var,'opSym)term) ==
  xs x. s = asSort xs  X = Var xs x"

definition castVar where
"castVar s (X :: ('index,'bindex,'varSort,'var,'opSym)term) ==
 SOME xs_x. s = asSort (fst xs_x)  X = Var (fst xs_x) (snd xs_x)"

definition isOp where
"isOp s X 
  delta inp binp.
   wlsInp delta inp  wlsBinp delta binp  s = stOf delta  X = Op delta inp binp"

definition castOp where
"castOp s X 
 SOME delta_inp_binp.
   wlsInp (fst3 delta_inp_binp) (snd3 delta_inp_binp) 
   wlsBinp (fst3 delta_inp_binp) (trd3 delta_inp_binp) 
   s = stOf (fst3 delta_inp_binp) 
   X = Op (fst3 delta_inp_binp) (snd3 delta_inp_binp) (trd3 delta_inp_binp)"

definition sortTermCase where
"sortTermCase fVar fOp s X 
 if isVar s X then fVar (fst (castVar s X)) (snd (castVar s X))
                else if isOp s X then fOp (fst3 (castOp s X)) (snd3 (castOp s X))  (trd3 (castOp s X))
                     else undefined"

(* Properties of isVar and castVar: *)

lemma isVar_asSort_Var[simp]:
"isVar (asSort xs) (Var xs x)"
unfolding isVar_def by auto

lemma not_isVar_Op[simp]:
"¬ isVar s (Op delta inp binp)"
unfolding isVar_def by auto

lemma isVar_imp_wls:
"isVar s X  wls s X"
unfolding isVar_def by auto

lemmas isVar_simps =
isVar_asSort_Var not_isVar_Op

lemma castVar_asSort_Var[simp]:
"castVar (asSort xs) (Var xs x) = (xs,x)"
unfolding castVar_def by (rule some_equality) auto

lemma isVar_castVar:
assumes "isVar s X"
shows "asSort (fst (castVar s X)) = s 
       Var (fst (castVar s X)) (snd (castVar s X)) = X"
using assms isVar_def by auto

lemma asSort_castVar[simp]:
"isVar s X  asSort (fst (castVar s X)) = s"
using isVar_castVar by auto

lemma Var_castVar[simp]:
"isVar s X  Var (fst (castVar s X)) (snd (castVar s X)) = X"
using isVar_castVar by auto

lemma castVar_inj[simp]:
assumes *: "isVar s X" and **: "isVar s' X'"
shows "(castVar s X = castVar s' X') = (s = s'  X = X')"
using assms Var_castVar asSort_castVar by fastforce 

lemmas castVar_simps =
castVar_asSort_Var
asSort_castVar Var_castVar castVar_inj

(* Properties of isOp and castOp: *)

lemma isOp_stOf_Op[simp]:
"wlsInp delta inp; wlsBinp delta binp
  isOp (stOf delta) (Op delta inp binp)"
unfolding isOp_def by auto

lemma not_isOp_Var[simp]:
"¬ isOp s (Var xs X)"
unfolding isOp_def by auto

lemma isOp_imp_wls:
"isOp s X  wls s X"
unfolding isOp_def by auto

lemmas isOp_simps =
isOp_stOf_Op not_isOp_Var

lemma castOp_stOf_Op[simp]:
assumes "wlsInp delta inp" and "wlsBinp delta binp"
shows "castOp (stOf delta) (Op delta inp binp) = (delta,inp,binp)"
using assms unfolding castOp_def by (intro some_equality) auto

lemma isOp_castOp:
assumes "isOp s X"
shows "wlsInp (fst3 (castOp s X)) (snd3 (castOp s X)) 
       wlsBinp (fst3 (castOp s X)) (trd3 (castOp s X)) 
       stOf (fst3 (castOp s X)) = s 
       Op (fst3 (castOp s X)) (snd3 (castOp s X)) (trd3 (castOp s X)) = X"
proof-
  let ?phi = "λ DIB. wlsInp (fst3 DIB) (snd3 DIB) 
                      wlsBinp (fst3 DIB) (trd3 DIB) 
                      s = stOf (fst3 DIB) 
                      X = Op (fst3 DIB) (snd3 DIB) (trd3 DIB)"
  obtain delta inp binp where "?phi (delta,inp,binp)"
  using assms unfolding isOp_def by auto
  hence "?phi (castOp s X)" using someI[of ?phi] by simp
  thus ?thesis by simp
qed

lemma wlsInp_castOp[simp]:
"isOp s X  wlsInp (fst3 (castOp s X)) (snd3 (castOp s X))"
using isOp_castOp by auto

lemma wlsBinp_castOp[simp]:
"isOp s X  wlsBinp (fst3 (castOp s X)) (trd3 (castOp s X))"
using isOp_castOp by auto

lemma stOf_castOp[simp]:
"isOp s X  stOf (fst3 (castOp s X)) = s"
using isOp_castOp by auto

lemma Op_castOp[simp]:
"isOp s X 
 Op (fst3 (castOp s X)) (snd3 (castOp s X)) (trd3 (castOp s X)) = X"
using isOp_castOp by auto

lemma castOp_inj[simp]:
assumes "isOp s X" and "isOp s' X'"
shows "(castOp s X = castOp s' X') = (s = s'  X = X')"
using assms Op_castOp stOf_castOp by fastforce
 
lemmas castOp_simps =
castOp_stOf_Op wlsInp_castOp wlsBinp_castOp
stOf_castOp Op_castOp castOp_inj

(* isVar and castVar versus isOp and castOp: *)

lemma not_isVar_isOp:
"¬ (isVar s X  isOp s X)"
unfolding isVar_def isOp_def by auto

lemma isVar_or_isOp:
"wls s X  isVar s X  isOp s X"
by(erule wls_cases) auto

(* Properties of the case-analysis operator: *)

lemma sortTermCase_asSort_Var_simp[simp]:
"sortTermCase fVar fOp (asSort xs) (Var xs x) = fVar xs x"
unfolding sortTermCase_def by auto

lemma sortTermCase_stOf_Op_simp[simp]:
"wlsInp delta inp; wlsBinp delta binp 
 sortTermCase fVar fOp (stOf delta) (Op delta inp binp) = fOp delta inp binp"
unfolding sortTermCase_def by auto

lemma sortTermCase_cong[fundef_cong]:
assumes " xs x. fVar xs x = gVar xs x"
and " delta inp binp. wlsInp delta inp; wlsInp delta inp
                         fOp delta inp binp = gOp delta inp binp"
shows "wls s X 
       sortTermCase fVar fOp s X = sortTermCase gVar gOp s X"
apply(erule wls_cases) using assms by auto

lemmas sortTermCase_simps =
sortTermCase_asSort_Var_simp
sortTermCase_stOf_Op_simp

lemmas term_cast_simps =
isOp_simps castOp_simps sortTermCase_simps

subsubsection ‹For abstractions›

text ‹Here, the situation will be different than that of terms, since:
\\- an abstraction can only be built using ``Abs", hence we need no ``is" operators;
\\- the constructor ``Abs" for abstractions is not injective, so need a more subtle condition
on the case-analysis operator.

Yet another difference is that when casting an abstraction ``A" such that ``wlsAbs (xs,s) A",
we need to cast only the value ``A", and not the sorting part``xs s", since the latter
already contains the desired information. Consequently, below, in the arguments for the case-analysis
operator, the sorts ``xs s" come before the function ``f", and the latter doesnot take sorts into account.›

(* Definitions: *)

definition castAbs where
"castAbs xs s A  SOME x_X. wls s (snd x_X)  A = Abs xs (fst x_X) (snd x_X)"

definition absCase where
"absCase xs s f A  if wlsAbs (xs,s) A then f (fst (castAbs xs s A)) (snd (castAbs xs s A)) else undefined"

definition compatAbsSwap where
"compatAbsSwap xs s f 
  x X x' X'. ( y. (y = x  fresh xs y X)  (y = x'  fresh xs y X')
                     (X #[y  x]_xs) = (X' #[y  x']_xs))
               f x X = f x' X'"

definition compatAbsSubst where
"compatAbsSubst xs s f 
  x X x' X'. ( Y. wls (asSort xs) Y  (X #[Y / x]_xs) = (X' #[Y / x']_xs))
               f x X = f x' X'"

definition compatAbsVsubst where
"compatAbsVsubst xs s f 
  x X x' X'. ( y. (X #[y // x]_xs) = (X' #[y // x']_xs))
               f x X = f x' X'"

(* Properties of castAbs: *)

lemma wlsAbs_castAbs:
assumes "wlsAbs (xs,s) A"
shows "wls s (snd (castAbs xs s A)) 
       Abs xs (fst (castAbs xs s A)) (snd (castAbs xs s A)) = A"
proof-
  let ?phi = "λ x_X. wls s (snd x_X) 
                     A = Abs xs (fst x_X) (snd x_X)"
  obtain x X where "?phi (x,X)" using assms wlsAbs_nchotomy[of xs s A] by auto
  hence "?phi (castAbs xs s A)" unfolding castAbs_def using someI[of ?phi] by auto
  thus ?thesis by simp
qed

lemma wls_castAbs[simp]:
"wlsAbs (xs,s) A  wls s (snd (castAbs xs s A))"
using wlsAbs_castAbs by auto

lemma Abs_castAbs[simp]:
"wlsAbs (xs,s) A  Abs xs (fst (castAbs xs s A)) (snd (castAbs xs s A)) = A"
using wlsAbs_castAbs by auto

lemma castAbs_Abs_swap:
assumes "isInBar (xs,s)" and X: "wls s X"
and yxX: "y = x  fresh xs y X" and yx'X': "y = x'  fresh xs y X'"
and *: "castAbs xs s (Abs xs x X) = (x',X')"
shows "(X #[y  x]_xs) = (X' #[y  x']_xs)"
proof-
  have "wlsAbs (xs,s) (Abs xs x X)" using assms by simp
  moreover
  have "x' = fst (castAbs xs s (Abs xs x X))" and
       "X' = snd (castAbs xs s (Abs xs x X))" using * by auto
  ultimately
  have "wls s X'" and "Abs xs x X = Abs xs x' X'" by auto
  thus ?thesis using yxX yx'X' X by(auto simp add: wls_Abs_swap_all)
qed

lemma castAbs_Abs_subst:
assumes isInBar: "isInBar (xs,s)"
and X: "wls s X" and Y: "wls (asSort xs) Y"
and *: "castAbs xs s (Abs xs x X) = (x',X')"
shows "(X #[Y / x]_xs) = (X' #[Y / x']_xs)"
proof-
  have "wlsAbs (xs,s) (Abs xs x X)" using isInBar X by simp
  moreover
  have "x' = fst (castAbs xs s (Abs xs x X))" and
       "X' = snd (castAbs xs s (Abs xs x X))" using * by auto
  ultimately
  have "wls s X'" and "Abs xs x X = Abs xs x' X'" by auto
  thus ?thesis using Y X by(auto simp add: wls_Abs_subst_all)
qed

lemma castAbs_Abs_vsubst:
assumes "isInBar (xs,s)" and "wls s X"
and "castAbs xs s (Abs xs x X) = (x',X')"
shows "(X #[y // x]_xs) = (X' #[y // x']_xs)"
using assms unfolding vsubst_def  
by (intro castAbs_Abs_subst) auto

lemma castAbs_inj[simp]:
assumes *: "wlsAbs (xs,s) A" and **: "wlsAbs (xs,s) A'"
shows "(castAbs xs s A = castAbs xs s A') = (A = A')"
using assms Abs_castAbs by fastforce

lemmas castAbs_simps =
wls_castAbs Abs_castAbs castAbs_inj

(* Properties of the case-analysis operator: *)

lemma absCase_Abs_swap[simp]:
assumes isInBar: "isInBar (xs,s)" and X: "wls s X"
and f_compat: "compatAbsSwap xs s f"
shows "absCase xs s f (Abs xs x X) = f x X"
proof-
  obtain x' X' where 1: "castAbs xs s (Abs xs x X) = (x',X')"
  by (cases "castAbs xs s (Abs xs x X)", auto)
  hence 2: "absCase xs s f (Abs xs x X) = f x' X'"
  unfolding absCase_def using isInBar X by auto
  have " y. (y = x  fresh xs y X)  (y = x'  fresh xs y X')
               (X #[y  x]_xs) = (X' #[y  x']_xs)"
  using isInBar X 1 by(simp add: castAbs_Abs_swap)
  hence "f x X = f x' X'" using f_compat
  unfolding compatAbsSwap_def by fastforce
  thus ?thesis using 2 by simp
qed

lemma absCase_Abs_subst[simp]:
assumes isInBar: "isInBar (xs,s)" and X: "wls s X"
and f_compat: "compatAbsSubst xs s f"
shows "absCase xs s f (Abs xs x X) = f x X"
proof-
  obtain x' X' where 1: "castAbs xs s (Abs xs x X) = (x',X')"
  by (cases "castAbs xs s (Abs xs x X)") auto
  hence 2: "absCase xs s f (Abs xs x X) = f x' X'"
  unfolding absCase_def using isInBar X by auto
  have " Y. wls (asSort xs) Y  (X #[Y / x]_xs) = (X' #[Y / x']_xs)"
  using isInBar X 1 by(simp add: castAbs_Abs_subst)
  hence "f x X = f x' X'" using f_compat unfolding compatAbsSubst_def by blast
  thus ?thesis using 2 by simp
qed

lemma compatAbsVsubst_imp_compatAbsSubst[simp]:
"compatAbsVsubst xs s f  compatAbsSubst xs s f"
unfolding compatAbsSubst_def compatAbsVsubst_def
vsubst_def by auto

lemma absCase_Abs_vsubst[simp]:
assumes "isInBar (xs,s)" and "wls s X"
and "compatAbsVsubst xs s f"
shows "absCase xs s f (Abs xs x X) = f x X"
using assms by(simp add: absCase_Abs_subst)

lemma absCase_cong[fundef_cong]:
assumes "compatAbsSwap xs s f  compatAbsSubst xs s f  compatAbsVsubst xs s f"
and "compatAbsSwap xs s f'  compatAbsSubst xs s f'  compatAbsVsubst xs s f'"
and " x X. wls s X  f x X = f' x X"
shows "wlsAbs (xs,s) A 
       absCase xs s f A = absCase xs s f' A"
apply(erule wlsAbs_cases) using assms by auto

lemmas absCase_simps = absCase_Abs_swap absCase_Abs_subst
compatAbsVsubst_imp_compatAbsSubst absCase_Abs_vsubst

lemmas abs_cast_simps = castAbs_simps absCase_simps

lemmas cast_simps = term_cast_simps abs_cast_simps

lemmas wls_item_simps =
wlsAll_imp_goodAll  paramS_simps Cons_wls_simps all_preserve_wls
wls_freeCons wls_allOpers_simps wls_allOpers_otherSimps Abs_inj_fresh cast_simps


(* Since the transition from good terms to well-sorted terms is complete, we
no longer need the ``good" layer: *) 

lemmas wls_copy_of_good_item_simps = good_freeCons  good_allOpers_simps good_allOpers_otherSimps
param_simps  all_preserve_good

declare wls_copy_of_good_item_simps [simp del]
declare qItem_simps [simp del]   declare qItem_versus_item_simps [simp del]

end (* context FixSyn  *)

end

Theory Iteration

section ‹Iteration›

theory Iteration imports Well_Sorted_Terms
begin

text‹In this section, we introduce first-order models (models, for short).
These are structures having operators that
match those for terms (including variable-injection, binding operations, freshness,
swapping and substitution) and satisfy some clauses,
and show that terms form initial models. This gives iteration principles.

As a matter of notation: the prefix
``g" will stand for ``generalized" -- elements of models are referred to as ``generalized terms".
The actual full prefix will be ``ig" (where ``i" stands for ``iteration"), symbolizing the fact that
the models from this section support iteration, and not general recursion.
The latter is dealt with by the models introduced in the next section, for which we
use the simple prefix ``g".
›

subsection ‹Models›

text‹We have two basic kinds of models:
\\- fresh-swap (FSw) models, featuring operations corresponding to
the concrete syntactic constructs (``Var", ``Op", ``Abs"),
henceforth referred to simply as {\em the constructs}, and to fresh and swap;
\\- fresh-swap-subst (FSb) models, featuring substitution instead of swapping.

We also consider two combinations of the above, FSwSb-models and FSbSw-models.

To keep things structurally
simple, we use one single Isabelle for all the 4 kinds models,
allowing the most generous signature.
Since terms are the main actors of our theory, models being considered only
for the sake of recursive definitions, we call the items inhabiting these models
``generalized" terms, abstractions and inputs, and correspondingly
the operations; hence the prefix ``g" from the names of the type parameters and
operators.
(However,
we refer to the generalized items using the same notations as for
``concrete items": X, A,  etc.)
%
Indeed, a model can be regarded as implementing
a generalization/axiomatization of the term structure, where now the objects are
not terms, but do have term-like properties.
›

subsubsection ‹Raw models›

record ('index,'bindex,'varSort,'sort,'opSym,'var,'gTerm,'gAbs)model =
  igWls :: "'sort  'gTerm  bool"
  igWlsAbs :: "'varSort × 'sort  'gAbs  bool"
  (*  *)
  igVar :: "'varSort  'var  'gTerm"
  igAbs :: "'varSort  'var  'gTerm  'gAbs"
  igOp :: "'opSym  ('index,'gTerm)input  ('bindex,'gAbs)input  'gTerm"
  (*  *)
  igFresh :: "'varSort  'var  'gTerm  bool"
  igFreshAbs :: "'varSort  'var  'gAbs  bool"
  (*  *)
  igSwap :: "'varSort  'var  'var  'gTerm  'gTerm"
  igSwapAbs :: "'varSort  'var  'var  'gAbs  'gAbs"
  (*   *)
  igSubst :: "'varSort  'gTerm  'var  'gTerm  'gTerm"
  igSubstAbs :: "'varSort  'gTerm  'var  'gAbs  'gAbs"

text‹\
\\- ``igSwap MOD zs z1 z2 X" swaps in X z1 and z2 (assumed of sorts zs).
\\- ``igSubst MOD ys Y x X" substitutes, in X, Y with y (assumed of sort ys).›

definition igFreshInp where
"igFreshInp MOD ys y inp == liftAll (igFresh MOD ys y) inp"

definition igFreshBinp where
"igFreshBinp MOD ys y binp == liftAll (igFreshAbs MOD ys y) binp"

definition igSwapInp where
"igSwapInp MOD zs z1 z2 inp == lift (igSwap MOD zs z1 z2) inp"

definition igSwapBinp where
"igSwapBinp MOD zs z1 z2 binp == lift (igSwapAbs MOD zs z1 z2) binp"

definition igSubstInp where
"igSubstInp MOD ys Y y inp == lift (igSubst MOD ys Y y) inp"

definition igSubstBinp where
"igSubstBinp MOD ys Y y binp == lift (igSubstAbs MOD ys Y y) binp"

(* *************************************************** *)
context FixSyn
begin

(*  In this theory, new type variables are introduced into the context,
corresponding to 'gTerm and 'gAbs (making the locale polymorphic).  *)

subsubsection ‹Well-sorted models of various kinds›

text‹We define the following kinds of well-sorted models
\\- fresh-swap models (predicate ``iwlsFSw");
\\- fresh-subst models (``iwlsFSb");
\\- fresh-swap-subst models (``iwlsFSwSb");
\\- fresh-subst-swap models (``iwlsFSbSw").

All of these models are defined as raw models subject to various Horn conditions:
\\- For ``iwlsFSw":
\\--- definition-like clauses for ``fresh" and ``swap" in terms of the
      construct operators;
\\--- congruence for abstraction based on fresh and swap (mirroring the abstraction case in
the definition of alpha-equivalence for quasi-terms).
%
\footnote{Here, by ``congruence for abstraction" we do not mean the standard notion of congrunece
(satisfied by any operator once or ever), but a {\em stronger} notion: in order for two abstractions
to be equal, it is not required that their ariguments be equal, but that they be in a
``permutative" relationship based either on swapping or on substitution.}
%
\\- For ``iwlsFSb": the same as for ``iwlsFSw", except that:
\\--- ``swap" is replaced by ``subst";
%
\footnote{
Note that traditionally alpha-equivalence is defined using ``subst", not ``swap".
}
%
\\--- The [fresh and swap]-based congrunce clause is replaced by an ``abstraction-renaming" clause,
which is stronger than the corresponding [fresh and subst]-based congruence clause.
%
\footnote{
We also define the [fresh and subst]-based congruence clause, although we do not
employ it directly in the definition of any kind of model.
}
%
\\- For ``iwlsFSwSb": the clauses for ``iwlsFSw", plus some of the definition-like clauses for ``subst".
%
\footnote{Not all the ``subst" definition-like clauses from ``iwlsFSb" are required
for ``iwlsFSwSb" -- namely, the clause that
we call ``igSubstIGAbsCls2" is not required here.
}
%
\\- For ``iwlsFSbSw": the clauses for ``iwlsFSb", plus definition-like clauses for ``swap".

Thus, a fresh-swap-subst model is also a fresh-swap model, and
a fresh-subst-swap model is also a fresh-subst model.

For convenience, all these 4 kinds of models are defined on one single type, that of {\em raw models},
which interpret the most generous signature, comprizing all the operations and relations required by all
4 kinds of models.
Note that, although some operations (namely, ``subst" or ``swap") may not be involved in the clauses for certain kinds
of models, the extra structure is harmless to the development of their theory.

Note that for the models operations and relations we do not actually write ``fresh", ``swap" and ``subst", but
``igFresh", ``igSwap" and ``igSubst".

As usual, we shall have not only term versions, but also abstraction versions of the above
operations.

›

definition igWlsInp where
"igWlsInp MOD delta inp ==
 wlsOpS delta  sameDom (arOf delta) inp  liftAll2 (igWls MOD) (arOf delta) inp"

lemmas igWlsInp_defs = igWlsInp_def sameDom_def liftAll2_def

definition igWlsBinp where
"igWlsBinp MOD delta binp ==
 wlsOpS delta  sameDom (barOf delta) binp  liftAll2 (igWlsAbs MOD) (barOf delta) binp"

lemmas igWlsBinp_defs = igWlsBinp_def sameDom_def liftAll2_def

text‹Domain disjointness:›

definition igWlsDisj where
"igWlsDisj MOD ==  s s' X. igWls MOD s X  igWls MOD s' X  s = s'"

definition igWlsAbsDisj where
"igWlsAbsDisj MOD ==
  xs s xs' s' A.
    isInBar (xs,s)  isInBar (xs',s') 
    igWlsAbs MOD (xs,s) A  igWlsAbs MOD (xs',s') A
     xs = xs'  s = s'"

definition igWlsAllDisj where
"igWlsAllDisj MOD ==
 igWlsDisj MOD  igWlsAbsDisj MOD"

lemmas igWlsAllDisj_defs =
igWlsAllDisj_def
igWlsDisj_def igWlsAbsDisj_def

text ‹Abstration domains inhabited only within bound arities:›

definition igWlsAbsIsInBar where
"igWlsAbsIsInBar MOD ==
  us s A. igWlsAbs MOD (us,s) A  isInBar (us,s)"

text‹Domain preservation by the operators: weak (``if") versions and strong (``iff") versions
(for the latter, we use the suffix ``STR"):›

text‹The constructs preserve the domains:›

definition igVarIPresIGWls where
"igVarIPresIGWls MOD ==
  xs x. igWls MOD (asSort xs) (igVar MOD xs x)"

definition igAbsIPresIGWls where
"igAbsIPresIGWls MOD ==
  xs s x X. isInBar (xs,s)  igWls MOD s X 
             igWlsAbs MOD (xs,s) (igAbs MOD xs x X)"

definition igAbsIPresIGWlsSTR where
"igAbsIPresIGWlsSTR MOD ==
  xs s x X. isInBar (xs,s) 
             igWlsAbs MOD (xs,s) (igAbs MOD xs x X) =
             igWls MOD s X"

lemma igAbsIPresIGWlsSTR_imp_igAbsIPresIGWls:
"igAbsIPresIGWlsSTR MOD  igAbsIPresIGWls MOD"
unfolding igAbsIPresIGWlsSTR_def igAbsIPresIGWls_def by simp

definition igOpIPresIGWls where
"igOpIPresIGWls MOD ==
  delta inp binp.
   igWlsInp MOD delta inp  igWlsBinp MOD delta binp
    igWls MOD (stOf delta) (igOp MOD delta inp binp)"

definition igOpIPresIGWlsSTR where
"igOpIPresIGWlsSTR MOD ==
  delta inp binp.
    igWls MOD (stOf delta) (igOp MOD delta inp binp) =
    (igWlsInp MOD delta inp  igWlsBinp MOD delta binp)"

lemma igOpIPresIGWlsSTR_imp_igOpIPresIGWls:
"igOpIPresIGWlsSTR MOD  igOpIPresIGWls MOD"
unfolding igOpIPresIGWlsSTR_def igOpIPresIGWls_def by simp

definition igConsIPresIGWls where
"igConsIPresIGWls MOD ==
 igVarIPresIGWls MOD 
 igAbsIPresIGWls MOD 
 igOpIPresIGWls MOD"

lemmas igConsIPresIGWls_defs = igConsIPresIGWls_def
igVarIPresIGWls_def
igAbsIPresIGWls_def
igOpIPresIGWls_def

definition igConsIPresIGWlsSTR where
"igConsIPresIGWlsSTR MOD ==
 igVarIPresIGWls MOD 
 igAbsIPresIGWlsSTR MOD 
 igOpIPresIGWlsSTR MOD"

lemmas igConsIPresIGWlsSTR_defs = igConsIPresIGWlsSTR_def
igVarIPresIGWls_def
igAbsIPresIGWlsSTR_def
igOpIPresIGWlsSTR_def

lemma igConsIPresIGWlsSTR_imp_igConsIPresIGWls:
"igConsIPresIGWlsSTR MOD  igConsIPresIGWls MOD"
unfolding igConsIPresIGWlsSTR_def igConsIPresIGWls_def
using
igAbsIPresIGWlsSTR_imp_igAbsIPresIGWls
igOpIPresIGWlsSTR_imp_igOpIPresIGWls
by auto

(* The notion of ``fresh" preserving well-sorted-ness does not make sense, since
``fresh" is a relation. *)

text‹``swap" preserves the domains:›

definition igSwapIPresIGWls where
"igSwapIPresIGWls MOD ==
  zs z1 z2 s X. igWls MOD s X 
                 igWls MOD s (igSwap MOD zs z1 z2 X)"

definition igSwapIPresIGWlsSTR where
"igSwapIPresIGWlsSTR MOD ==
  zs z1 z2 s X. igWls MOD s (igSwap MOD zs z1 z2 X) =
                 igWls MOD s X"

lemma igSwapIPresIGWlsSTR_imp_igSwapIPresIGWls:
"igSwapIPresIGWlsSTR MOD  igSwapIPresIGWls MOD"
unfolding igSwapIPresIGWlsSTR_def igSwapIPresIGWls_def by simp

definition igSwapAbsIPresIGWlsAbs where
"igSwapAbsIPresIGWlsAbs MOD ==
  zs z1 z2 us s A.
   isInBar (us,s)  igWlsAbs MOD (us,s) A 
   igWlsAbs MOD (us,s) (igSwapAbs MOD zs z1 z2 A)"

definition igSwapAbsIPresIGWlsAbsSTR where
"igSwapAbsIPresIGWlsAbsSTR MOD ==
  zs z1 z2 us s A.
   igWlsAbs MOD (us,s) (igSwapAbs MOD zs z1 z2 A) =
   igWlsAbs MOD (us,s) A"

lemma igSwapAbsIPresIGWlsAbsSTR_imp_igSwapAbsIPresIGWlsAbs:
"igSwapAbsIPresIGWlsAbsSTR MOD  igSwapAbsIPresIGWlsAbs MOD"
unfolding igSwapAbsIPresIGWlsAbsSTR_def igSwapAbsIPresIGWlsAbs_def by simp

definition igSwapAllIPresIGWlsAll where
"igSwapAllIPresIGWlsAll MOD ==
 igSwapIPresIGWls MOD  igSwapAbsIPresIGWlsAbs MOD"

lemmas igSwapAllIPresIGWlsAll_defs = igSwapAllIPresIGWlsAll_def
igSwapIPresIGWls_def igSwapAbsIPresIGWlsAbs_def

definition igSwapAllIPresIGWlsAllSTR where
"igSwapAllIPresIGWlsAllSTR MOD ==
 igSwapIPresIGWlsSTR MOD  igSwapAbsIPresIGWlsAbsSTR MOD"

lemmas igSwapAllIPresIGWlsAllSTR_defs = igSwapAllIPresIGWlsAllSTR_def
igSwapIPresIGWlsSTR_def igSwapAbsIPresIGWlsAbsSTR_def

lemma igSwapAllIPresIGWlsAllSTR_imp_igSwapAllIPresIGWlsAll:
"igSwapAllIPresIGWlsAllSTR MOD  igSwapAllIPresIGWlsAll MOD"
unfolding igSwapAllIPresIGWlsAllSTR_def igSwapAllIPresIGWlsAll_def
using
igSwapIPresIGWlsSTR_imp_igSwapIPresIGWls
igSwapAbsIPresIGWlsAbsSTR_imp_igSwapAbsIPresIGWlsAbs
by auto

text‹``subst" preserves the domains:›

definition igSubstIPresIGWls where
"igSubstIPresIGWls MOD ==
  ys Y y s X. igWls MOD (asSort ys) Y  igWls MOD s X 
               igWls MOD s (igSubst MOD ys Y y X)"

definition igSubstIPresIGWlsSTR where
"igSubstIPresIGWlsSTR MOD ==
  ys Y y s X.
   igWls MOD s (igSubst MOD ys Y y X) =
   (igWls MOD (asSort ys) Y  igWls MOD s X)"

lemma igSubstIPresIGWlsSTR_imp_igSubstIPresIGWls:
"igSubstIPresIGWlsSTR MOD  igSubstIPresIGWls MOD"
unfolding igSubstIPresIGWlsSTR_def igSubstIPresIGWls_def by simp

definition igSubstAbsIPresIGWlsAbs where
"igSubstAbsIPresIGWlsAbs MOD ==
  ys Y y us s A.
   isInBar (us,s)  igWls MOD (asSort ys) Y  igWlsAbs MOD (us,s) A 
   igWlsAbs MOD (us,s) (igSubstAbs MOD ys Y y A)"

definition igSubstAbsIPresIGWlsAbsSTR where
"igSubstAbsIPresIGWlsAbsSTR MOD ==
  ys Y y us s A.
   igWlsAbs MOD (us,s) (igSubstAbs MOD ys Y y A) =
   (igWls MOD (asSort ys) Y  igWlsAbs MOD (us,s) A)"

lemma igSubstAbsIPresIGWlsAbsSTR_imp_igSubstAbsIPresIGWlsAbs:
"igSubstAbsIPresIGWlsAbsSTR MOD  igSubstAbsIPresIGWlsAbs MOD"
unfolding igSubstAbsIPresIGWlsAbsSTR_def igSubstAbsIPresIGWlsAbs_def by simp

definition igSubstAllIPresIGWlsAll where
"igSubstAllIPresIGWlsAll MOD ==
 igSubstIPresIGWls MOD  igSubstAbsIPresIGWlsAbs MOD"

lemmas igSubstAllIPresIGWlsAll_defs = igSubstAllIPresIGWlsAll_def
igSubstIPresIGWls_def igSubstAbsIPresIGWlsAbs_def

definition igSubstAllIPresIGWlsAllSTR where
"igSubstAllIPresIGWlsAllSTR MOD ==
 igSubstIPresIGWlsSTR MOD  igSubstAbsIPresIGWlsAbsSTR MOD"

lemmas igSubstAllIPresIGWlsAllSTR_defs = igSubstAllIPresIGWlsAllSTR_def
igSubstIPresIGWlsSTR_def igSubstAbsIPresIGWlsAbsSTR_def

lemma igSubstAllIPresIGWlsAllSTR_imp_igSubstAllIPresIGWlsAll:
"igSubstAllIPresIGWlsAllSTR MOD  igSubstAllIPresIGWlsAll MOD"
unfolding igSubstAllIPresIGWlsAllSTR_def igSubstAllIPresIGWlsAll_def
using
igSubstIPresIGWlsSTR_imp_igSubstIPresIGWls
igSubstAbsIPresIGWlsAbsSTR_imp_igSubstAbsIPresIGWlsAbs
by auto

text‹Clauses for fresh: fully conditional versions and less conditional,
stronger versions (the latter having suffix ``STR").›

definition igFreshIGVar where
"igFreshIGVar MOD ==
  ys y xs x.
   ys  xs  y  x 
   igFresh MOD ys y (igVar MOD xs x)"

definition igFreshIGAbs1 where
"igFreshIGAbs1 MOD ==
  ys y s X.
   isInBar (ys,s)  igWls MOD s X 
   igFreshAbs MOD ys y (igAbs MOD ys y X)"

definition igFreshIGAbs1STR where
"igFreshIGAbs1STR MOD ==
  ys y X. igFreshAbs MOD ys y (igAbs MOD ys y X)"

lemma igFreshIGAbs1STR_imp_igFreshIGAbs1:
"igFreshIGAbs1STR MOD  igFreshIGAbs1 MOD"
unfolding igFreshIGAbs1STR_def igFreshIGAbs1_def by simp

definition igFreshIGAbs2 where
"igFreshIGAbs2 MOD ==
  ys y xs x s X.
   isInBar (xs,s)  igWls MOD s X 
   igFresh MOD ys y X  igFreshAbs MOD ys y (igAbs MOD xs x X)"

definition igFreshIGAbs2STR where
"igFreshIGAbs2STR MOD ==
  ys y xs x X.
   igFresh MOD ys y X  igFreshAbs MOD ys y (igAbs MOD xs x X)"

lemma igFreshIGAbs2STR_imp_igFreshIGAbs2:
"igFreshIGAbs2STR MOD  igFreshIGAbs2 MOD"
unfolding igFreshIGAbs2STR_def igFreshIGAbs2_def by simp

definition igFreshIGOp where
"igFreshIGOp MOD ==
  ys y delta inp binp.
   igWlsInp MOD delta inp  igWlsBinp MOD delta binp 
   (igFreshInp MOD ys y inp  igFreshBinp MOD ys y binp) 
   igFresh MOD ys y (igOp MOD delta inp binp)"

definition igFreshIGOpSTR where
"igFreshIGOpSTR MOD ==
  ys y delta inp binp.
   igFreshInp MOD ys y inp  igFreshBinp MOD ys y binp 
   igFresh MOD ys y (igOp MOD delta inp binp)"

lemma igFreshIGOpSTR_imp_igFreshIGOp:
"igFreshIGOpSTR MOD  igFreshIGOp MOD"
unfolding igFreshIGOpSTR_def igFreshIGOp_def by simp

definition igFreshCls where
"igFreshCls MOD ==
igFreshIGVar MOD 
igFreshIGAbs1 MOD  igFreshIGAbs2 MOD 
igFreshIGOp MOD"

lemmas igFreshCls_defs = igFreshCls_def
igFreshIGVar_def
igFreshIGAbs1_def igFreshIGAbs2_def
igFreshIGOp_def

definition igFreshClsSTR where
"igFreshClsSTR MOD ==
igFreshIGVar MOD 
igFreshIGAbs1STR MOD  igFreshIGAbs2STR MOD 
igFreshIGOpSTR MOD"

lemmas igFreshClsSTR_defs = igFreshClsSTR_def
igFreshIGVar_def
igFreshIGAbs1STR_def igFreshIGAbs2STR_def
igFreshIGOpSTR_def

lemma igFreshClsSTR_imp_igFreshCls:
"igFreshClsSTR MOD  igFreshCls MOD"
unfolding igFreshClsSTR_def igFreshCls_def
using
igFreshIGAbs1STR_imp_igFreshIGAbs1 igFreshIGAbs2STR_imp_igFreshIGAbs2
igFreshIGOpSTR_imp_igFreshIGOp
by auto

(* Clauses for swap: fully-conditional versions and less-conditional,
stronger versions (suffix ``STR") *)

definition igSwapIGVar where
"igSwapIGVar MOD ==
  zs z1 z2 xs x.
   igSwap MOD zs z1 z2 (igVar MOD xs x) = igVar MOD xs (x @xs[z1  z2]_zs)"

definition igSwapIGAbs where
"igSwapIGAbs MOD ==
   zs z1 z2 xs x s X.
   isInBar (xs,s)  igWls MOD s X 
   igSwapAbs MOD zs z1 z2 (igAbs MOD xs x X) =
   igAbs MOD xs (x @xs[z1  z2]_zs) (igSwap MOD zs z1 z2 X)"

definition igSwapIGAbsSTR where
"igSwapIGAbsSTR MOD ==
   zs z1 z2 xs x X.
   igSwapAbs MOD zs z1 z2 (igAbs MOD xs x X) =
   igAbs MOD xs (x @xs[z1  z2]_zs) (igSwap MOD zs z1 z2 X)"

lemma igSwapIGAbsSTR_imp_igSwapIGAbs:
"igSwapIGAbsSTR MOD  igSwapIGAbs MOD"
unfolding igSwapIGAbsSTR_def igSwapIGAbs_def by simp

definition igSwapIGOp where
"igSwapIGOp MOD ==
   zs z1 z2 delta inp binp.
   igWlsInp MOD delta inp  igWlsBinp MOD delta binp 
   igSwap MOD zs z1 z2 (igOp MOD delta inp binp) =
   igOp MOD delta (igSwapInp MOD zs z1 z2 inp) (igSwapBinp MOD zs z1 z2 binp)"

definition igSwapIGOpSTR where
"igSwapIGOpSTR MOD ==
   zs z1 z2 delta inp binp.
   igSwap MOD zs z1 z2 (igOp MOD delta inp binp) =
   igOp MOD delta (igSwapInp MOD zs z1 z2 inp) (igSwapBinp MOD zs z1 z2 binp)"

lemma igSwapIGOpSTR_imp_igSwapIGOp:
"igSwapIGOpSTR MOD  igSwapIGOp MOD"
unfolding igSwapIGOpSTR_def igSwapIGOp_def by simp

definition igSwapCls where
"igSwapCls MOD ==
igSwapIGVar MOD 
igSwapIGAbs MOD 
igSwapIGOp MOD"

lemmas igSwapCls_defs = igSwapCls_def
igSwapIGVar_def
igSwapIGAbs_def
igSwapIGOp_def

definition igSwapClsSTR where
"igSwapClsSTR MOD ==
igSwapIGVar MOD 
igSwapIGAbsSTR MOD 
igSwapIGOpSTR MOD"

lemmas igSwapClsSTR_defs = igSwapClsSTR_def
igSwapIGVar_def
igSwapIGAbsSTR_def
igSwapIGOpSTR_def

lemma igSwapClsSTR_imp_igSwapCls:
"igSwapClsSTR MOD  igSwapCls MOD"
unfolding igSwapClsSTR_def igSwapCls_def
using
igSwapIGAbsSTR_imp_igSwapIGAbs
igSwapIGOpSTR_imp_igSwapIGOp
by auto

(* Clauses for subst: fully-conditional versions and less-conditional,
stronger versions (suffix ``STR") *)

definition igSubstIGVar1 where
"igSubstIGVar1 MOD ==
  ys y Y xs x.
   igWls MOD (asSort ys) Y 
   (ys  xs  y  x) 
   igSubst MOD ys Y y (igVar MOD xs x) = igVar MOD xs x"

definition igSubstIGVar1STR where
"igSubstIGVar1STR MOD ==
 ( ys y y1 xs x.
    (ys  xs  x  y) 
    igSubst MOD ys (igVar MOD ys y1) y (igVar MOD xs x) = igVar MOD xs x)
 
 ( ys y Y xs x.
    igWls MOD (asSort ys) Y 
    (ys  xs  y  x) 
    igSubst MOD ys Y y (igVar MOD xs x) = igVar MOD xs x)"

lemma igSubstIGVar1STR_imp_igSubstIGVar1:
"igSubstIGVar1STR MOD  igSubstIGVar1 MOD"
unfolding igSubstIGVar1STR_def igSubstIGVar1_def by simp

definition igSubstIGVar2 where
"igSubstIGVar2 MOD ==
  ys y Y.
   igWls MOD (asSort ys) Y 
   igSubst MOD ys Y y (igVar MOD ys y) = Y"

definition igSubstIGVar2STR where
"igSubstIGVar2STR MOD ==
 ( ys y y1.
    igSubst MOD ys (igVar MOD ys y1) y (igVar MOD ys y) = igVar MOD ys y1)
 
 ( ys y Y.
    igWls MOD (asSort ys) Y 
    igSubst MOD ys Y y (igVar MOD ys y) = Y)"

lemma igSubstIGVar2STR_imp_igSubstIGVar2:
"igSubstIGVar2STR MOD  igSubstIGVar2 MOD"
unfolding igSubstIGVar2STR_def igSubstIGVar2_def by simp

definition igSubstIGAbs where
"igSubstIGAbs MOD ==
  ys y Y xs x s X.
   isInBar (xs,s)  igWls MOD (asSort ys) Y  igWls MOD s X 
   (xs  ys  x  y)  igFresh MOD xs x Y 
   igSubstAbs MOD ys Y y (igAbs MOD xs x X) =
   igAbs MOD xs x (igSubst MOD ys Y y X)"

definition igSubstIGAbsSTR where
"igSubstIGAbsSTR MOD ==
  ys y Y xs x X.
   (xs  ys  x  y)  igFresh MOD xs x Y 
   igSubstAbs MOD ys Y y (igAbs MOD xs x X) =
   igAbs MOD xs x (igSubst MOD ys Y y X)"

lemma igSubstIGAbsSTR_imp_igSubstIGAbs:
"igSubstIGAbsSTR MOD  igSubstIGAbs MOD"
unfolding igSubstIGAbsSTR_def igSubstIGAbs_def by simp

definition igSubstIGOp where
"igSubstIGOp MOD ==
  ys y Y delta inp binp.
   igWls MOD (asSort ys) Y 
   igWlsInp MOD delta inp  igWlsBinp MOD delta binp 
   igSubst MOD ys Y y (igOp MOD delta inp binp) =
   igOp MOD delta (igSubstInp MOD ys Y y inp) (igSubstBinp MOD ys Y y binp)"

definition igSubstIGOpSTR where
"igSubstIGOpSTR MOD ==
 ( ys y y1 delta inp binp.
    igSubst MOD ys (igVar MOD ys y1) y (igOp MOD delta inp binp) =
    igOp MOD delta (igSubstInp MOD ys (igVar MOD ys y1) y inp)
                  (igSubstBinp MOD ys (igVar MOD ys y1) y binp))
 
 ( ys y Y delta inp binp.
    igWls MOD (asSort ys) Y 
    igSubst MOD ys Y y (igOp MOD delta inp binp) =
    igOp MOD delta (igSubstInp MOD ys Y y inp) (igSubstBinp MOD ys Y y binp))"

lemma igSubstIGOpSTR_imp_igSubstIGOp:
"igSubstIGOpSTR MOD  igSubstIGOp MOD"
unfolding igSubstIGOpSTR_def igSubstIGOp_def by simp

definition igSubstCls where
"igSubstCls MOD ==
 igSubstIGVar1 MOD  igSubstIGVar2 MOD 
 igSubstIGAbs MOD 
 igSubstIGOp MOD"

lemmas igSubstCls_defs = igSubstCls_def
igSubstIGVar1_def igSubstIGVar2_def
igSubstIGAbs_def
igSubstIGOp_def

definition igSubstClsSTR where
"igSubstClsSTR MOD ==
 igSubstIGVar1STR MOD  igSubstIGVar2STR MOD 
 igSubstIGAbsSTR MOD 
 igSubstIGOpSTR MOD"

lemmas igSubstClsSTR_defs = igSubstClsSTR_def
igSubstIGVar1STR_def igSubstIGVar2STR_def
igSubstIGAbsSTR_def
igSubstIGOpSTR_def

lemma igSubstClsSTR_imp_igSubstCls:
"igSubstClsSTR MOD  igSubstCls MOD"
unfolding igSubstClsSTR_def igSubstCls_def
using
igSubstIGVar1STR_imp_igSubstIGVar1
igSubstIGVar2STR_imp_igSubstIGVar2
igSubstIGAbsSTR_imp_igSubstIGAbs
igSubstIGOpSTR_imp_igSubstIGOp
by auto

(* Freshness-based congruences for abstractions: *)

(* ... employing swap: *)

definition igAbsCongS where
"igAbsCongS MOD ==
  xs x x' y s X X'.
   isInBar (xs,s)  igWls MOD s X  igWls MOD s X' 
   igFresh MOD xs y X  igFresh MOD xs y X'  igSwap MOD xs y x X = igSwap MOD xs y x' X' 
   igAbs MOD xs x X = igAbs MOD xs x' X'"

definition igAbsCongSSTR where
"igAbsCongSSTR MOD ==
  xs x x' y X X'.
   igFresh MOD xs y X  igFresh MOD xs y X'  igSwap MOD xs y x X = igSwap MOD xs y x' X' 
   igAbs MOD xs x X = igAbs MOD xs x' X'"

lemma igAbsCongSSTR_imp_igAbsCongS:
"igAbsCongSSTR MOD  igAbsCongS MOD"
unfolding igAbsCongSSTR_def igAbsCongS_def by auto

(* ... employing subst: *)

definition igAbsCongU where
"igAbsCongU MOD ==
  xs x x' y s X X'.
   isInBar (xs,s)  igWls MOD s X  igWls MOD s X' 
   igFresh MOD xs y X  igFresh MOD xs y X' 
   igSubst MOD xs (igVar MOD xs y) x X = igSubst MOD xs (igVar MOD xs y) x' X' 
   igAbs MOD xs x X = igAbs MOD xs x' X'"

definition igAbsCongUSTR where
"igAbsCongUSTR MOD ==
  xs x x' y X X'.
   igFresh MOD xs y X  igFresh MOD xs y X' 
   igSubst MOD xs (igVar MOD xs y) x X = igSubst MOD xs (igVar MOD xs y) x' X' 
   igAbs MOD xs x X = igAbs MOD xs x' X'"

lemma igAbsCongUSTR_imp_igAbsCongU:
"igAbsCongUSTR MOD  igAbsCongU MOD"
unfolding igAbsCongUSTR_def igAbsCongU_def by auto

(* (Subst-based) renaming of the bound variable in abstractions (``abstraction renaming", for short): *)

definition igAbsRen where
"igAbsRen MOD ==
  xs y x s X.
    isInBar (xs,s)  igWls MOD s X 
    igFresh MOD xs y X 
    igAbs MOD xs y (igSubst MOD xs (igVar MOD xs y) x X) = igAbs MOD xs x X"

definition igAbsRenSTR where
"igAbsRenSTR MOD ==
  xs y x X.
   igFresh MOD xs y X 
   igAbs MOD xs y (igSubst MOD xs (igVar MOD xs y) x X) = igAbs MOD xs x X"

lemma igAbsRenSTR_imp_igAbsRen:
"igAbsRenSTR MOD  igAbsRen MOD"
unfolding igAbsRenSTR_def igAbsRen_def by simp

(* igAbsRenSTR is stronger than igAbsCongUSTR: *)

lemma igAbsRenSTR_imp_igAbsCongUSTR:
"igAbsRenSTR MOD  igAbsCongUSTR MOD"
unfolding igAbsCongUSTR_def igAbsRenSTR_def by metis
  

text ‹Well-sorted fresh-swap models:›

definition iwlsFSw where
"iwlsFSw MOD ==
 igWlsAllDisj MOD  igWlsAbsIsInBar MOD 
 igConsIPresIGWls MOD  igSwapAllIPresIGWlsAll MOD 
 igFreshCls MOD  igSwapCls MOD  igAbsCongS MOD"

lemmas iwlsFSw_defs1 = iwlsFSw_def
igWlsAllDisj_def igWlsAbsIsInBar_def
igConsIPresIGWls_def igSwapAllIPresIGWlsAll_def
igFreshCls_def igSwapCls_def igAbsCongS_def

lemmas iwlsFSw_defs = iwlsFSw_def
igWlsAllDisj_defs igWlsAbsIsInBar_def
igConsIPresIGWls_defs igSwapAllIPresIGWlsAll_defs
igFreshCls_defs igSwapCls_defs igAbsCongS_def

definition iwlsFSwSTR where
"iwlsFSwSTR MOD ==
 igWlsAllDisj MOD  igWlsAbsIsInBar MOD 
 igConsIPresIGWlsSTR MOD  igSwapAllIPresIGWlsAllSTR MOD 
 igFreshClsSTR MOD  igSwapClsSTR MOD  igAbsCongSSTR MOD"

lemmas iwlsFSwSTR_defs1 = iwlsFSwSTR_def
igWlsAllDisj_def igWlsAbsIsInBar_def
igConsIPresIGWlsSTR_def igSwapAllIPresIGWlsAllSTR_def
igFreshClsSTR_def igSwapClsSTR_def igAbsCongSSTR_def

lemmas iwlsFSwSTR_defs = iwlsFSwSTR_def
igWlsAllDisj_defs igWlsAbsIsInBar_def
igConsIPresIGWlsSTR_defs igSwapAllIPresIGWlsAllSTR_defs
igFreshClsSTR_defs igSwapClsSTR_defs igAbsCongSSTR_def

lemma iwlsFSwSTR_imp_iwlsFSw:
"iwlsFSwSTR MOD  iwlsFSw MOD"
unfolding iwlsFSwSTR_def iwlsFSw_def
using
igConsIPresIGWlsSTR_imp_igConsIPresIGWls
igSwapAllIPresIGWlsAllSTR_imp_igSwapAllIPresIGWlsAll
igFreshClsSTR_imp_igFreshCls
igSwapClsSTR_imp_igSwapCls
igAbsCongSSTR_imp_igAbsCongS
by auto

text ‹Well-sorted fresh-subst models:›

definition iwlsFSb where
"iwlsFSb MOD ==
 igWlsAllDisj MOD  igWlsAbsIsInBar MOD 
 igConsIPresIGWls MOD  igSubstAllIPresIGWlsAll MOD 
 igFreshCls MOD  igSubstCls MOD  igAbsRen MOD"

lemmas iwlsFSb_defs1 = iwlsFSb_def
igWlsAllDisj_def igWlsAbsIsInBar_def
igConsIPresIGWls_def igSubstAllIPresIGWlsAll_def
igFreshCls_def igSubstCls_def igAbsRen_def

lemmas iwlsFSb_defs = iwlsFSb_def
igWlsAllDisj_defs igWlsAbsIsInBar_def
igConsIPresIGWls_defs igSubstAllIPresIGWlsAll_defs
igFreshCls_defs igSubstCls_defs igAbsRen_def

definition iwlsFSbSwTR where
"iwlsFSbSwTR MOD ==
 igWlsAllDisj MOD  igWlsAbsIsInBar MOD 
 igConsIPresIGWlsSTR MOD  igSubstAllIPresIGWlsAllSTR MOD 
 igFreshClsSTR MOD  igSubstClsSTR MOD  igAbsRenSTR MOD"

lemmas wlsFSbSwSTR_defs1 = iwlsFSbSwTR_def
igWlsAllDisj_def igWlsAbsIsInBar_def
igConsIPresIGWlsSTR_def igSwapAllIPresIGWlsAllSTR_def
igFreshClsSTR_def igSwapClsSTR_def igAbsRenSTR_def

lemmas iwlsFSbSwTR_defs = iwlsFSbSwTR_def
igWlsAllDisj_defs igWlsAbsIsInBar_def
igConsIPresIGWlsSTR_defs igSwapAllIPresIGWlsAllSTR_defs
igFreshClsSTR_defs igSwapClsSTR_defs igAbsRenSTR_def

lemma iwlsFSbSwTR_imp_iwlsFSb:
"iwlsFSbSwTR MOD  iwlsFSb MOD"
unfolding iwlsFSbSwTR_def iwlsFSb_def
using
igConsIPresIGWlsSTR_imp_igConsIPresIGWls
igSubstAllIPresIGWlsAllSTR_imp_igSubstAllIPresIGWlsAll
igFreshClsSTR_imp_igFreshCls
igSubstClsSTR_imp_igSubstCls
igAbsRenSTR_imp_igAbsRen
by auto

text ‹Well-sorted fresh-swap-subst-models›

(* "strong" versions not required for this kind of models *)

definition iwlsFSwSb where
"iwlsFSwSb MOD ==
 iwlsFSw MOD  igSubstAllIPresIGWlsAll MOD  igSubstCls MOD"

lemmas iwlsFSwSb_defs1 = iwlsFSwSb_def
iwlsFSw_def igSubstAllIPresIGWlsAll_def igSubstCls_def

lemmas iwlsFSwSb_defs = iwlsFSwSb_def
iwlsFSw_def igSubstAllIPresIGWlsAll_defs igSubstCls_defs

text ‹Well-sorted fresh-subst-swap-models›

(* "strong" versions not required for this kind of models *)

definition iwlsFSbSw where
"iwlsFSbSw MOD ==
 iwlsFSb MOD  igSwapAllIPresIGWlsAll MOD  igSwapCls MOD"

lemmas iwlsFSbSw_defs1 = iwlsFSbSw_def
iwlsFSw_def igSwapAllIPresIGWlsAll_def igSwapCls_def

lemmas iwlsFSbSw_defs = iwlsFSbSw_def
iwlsFSw_def igSwapAllIPresIGWlsAll_defs igSwapCls_defs

text‹Extension of domain preservation (by swap and subst) to inputs:›

text ‹First for free inputs:›

definition igSwapInpIPresIGWlsInp where
"igSwapInpIPresIGWlsInp MOD ==
  zs z1 z2 delta inp.
   igWlsInp MOD delta inp 
   igWlsInp MOD delta (igSwapInp MOD zs z1 z2 inp)"

definition igSwapInpIPresIGWlsInpSTR where
"igSwapInpIPresIGWlsInpSTR MOD ==
  zs z1 z2 delta inp.
   igWlsInp MOD delta (igSwapInp MOD zs z1 z2 inp) =
   igWlsInp MOD delta inp"

definition igSubstInpIPresIGWlsInp where
"igSubstInpIPresIGWlsInp MOD ==
  ys y Y delta inp.
   igWls MOD (asSort ys) Y  igWlsInp MOD delta inp 
   igWlsInp MOD delta (igSubstInp MOD ys Y y inp)"

definition igSubstInpIPresIGWlsInpSTR where
"igSubstInpIPresIGWlsInpSTR MOD ==
  ys y Y delta inp.
   igWls MOD (asSort ys) Y 
   igWlsInp MOD delta (igSubstInp MOD ys Y y inp) =
   igWlsInp MOD delta inp"

lemma imp_igSwapInpIPresIGWlsInp:
"igSwapIPresIGWls MOD  igSwapInpIPresIGWlsInp MOD"
by (simp add: 
igSwapInpIPresIGWlsInp_def igWlsInp_def liftAll2_def  
igSwapIPresIGWls_def igSwapAbsIPresIGWlsAbs_def igSwapInp_def lift_def 
sameDom_def split: option.splits)  

lemma imp_igSwapInpIPresIGWlsInpSTR:
"igSwapIPresIGWlsSTR MOD  igSwapInpIPresIGWlsInpSTR MOD"
by (simp add: 
igSwapIPresIGWlsSTR_def igWlsInp_def liftAll2_def  
igSwapIPresIGWls_def igSwapInpIPresIGWlsInpSTR_def igSwapInp_def lift_def 
sameDom_def split: option.splits)  
(smt option.distinct(1) option.exhaust) 

lemma imp_igSubstInpIPresIGWlsInp:
"igSubstIPresIGWls MOD  igSubstInpIPresIGWlsInp MOD"
by (simp add : igSubstInp_def
igSubstIPresIGWls_def igSubstInpIPresIGWlsInp_def igWlsInp_def liftAll2_def 
lift_def sameDom_def split: option.splits)

lemma imp_igSubstInpIPresIGWlsInpSTR:
"igSubstIPresIGWlsSTR MOD  igSubstInpIPresIGWlsInpSTR MOD"
by(simp add: 
igSubstInpIPresIGWlsInpSTR_def igSubstIPresIGWlsSTR_def igSubstInp_def
igWlsInp_def liftAll2_def lift_def sameDom_def 
split: option.splits) (smt option.distinct(1) option.exhaust) 

text ‹Then for bound inputs:›

definition igSwapBinpIPresIGWlsBinp where
"igSwapBinpIPresIGWlsBinp MOD ==
  zs z1 z2 delta binp.
   igWlsBinp MOD delta binp 
   igWlsBinp MOD delta (igSwapBinp MOD zs z1 z2 binp)"

definition igSwapBinpIPresIGWlsBinpSTR where
"igSwapBinpIPresIGWlsBinpSTR MOD ==
  zs z1 z2 delta binp.
   igWlsBinp MOD delta (igSwapBinp MOD zs z1 z2 binp) =
   igWlsBinp MOD delta binp"

definition igSubstBinpIPresIGWlsBinp where
"igSubstBinpIPresIGWlsBinp MOD ==
  ys y Y delta binp.
   igWls MOD (asSort ys) Y  igWlsBinp MOD delta binp 
   igWlsBinp MOD delta (igSubstBinp MOD ys Y y binp)"

definition igSubstBinpIPresIGWlsBinpSTR where
"igSubstBinpIPresIGWlsBinpSTR MOD ==
  ys y Y delta binp.
   igWls MOD (asSort ys) Y 
   igWlsBinp MOD delta (igSubstBinp MOD ys Y y binp) =
   igWlsBinp MOD delta binp"

lemma imp_igSwapBinpIPresIGWlsBinp:
"igSwapAbsIPresIGWlsAbs MOD  igSwapBinpIPresIGWlsBinp MOD"
by(auto simp add: 
igSwapBinpIPresIGWlsBinp_def igSwapAbsIPresIGWlsAbs_def igSwapBinp_def
igWlsBinp_def liftAll2_def lift_def sameDom_def 
split: option.splits)  

lemma imp_igSwapBinpIPresIGWlsBinpSTR:
"igSwapAbsIPresIGWlsAbsSTR MOD  igSwapBinpIPresIGWlsBinpSTR MOD"
by (simp add: 
igSwapBinpIPresIGWlsBinpSTR_def igSwapAbsIPresIGWlsAbsSTR_def igSwapBinp_def
igWlsBinp_def liftAll2_def lift_def sameDom_def 
split: option.splits) (smt option.distinct(1) option.exhaust surj_pair)

lemma imp_igSubstBinpIPresIGWlsBinp:
"igSubstAbsIPresIGWlsAbs MOD  igSubstBinpIPresIGWlsBinp MOD"
by (auto simp add: 
igSubstBinpIPresIGWlsBinp_def igSubstAbsIPresIGWlsAbs_def igSubstBinp_def
igWlsBinp_def liftAll2_def lift_def sameDom_def 
split: option.splits) 

lemma imp_igSubstBinpIPresIGWlsBinpSTR:
"igSubstAbsIPresIGWlsAbsSTR MOD  igSubstBinpIPresIGWlsBinpSTR MOD"
by (simp add: 
igSubstAbsIPresIGWlsAbsSTR_def igSubstBinpIPresIGWlsBinpSTR_def igSubstBinp_def
igWlsBinp_def liftAll2_def lift_def sameDom_def 
split: option.splits) (smt option.distinct(1) option.exhaust surj_pair) 

subsection ‹Morphisms of models›

text‹
The morphisms between models shall be the usual first-order-logic morphisms, i.e,, functions
commuting with the operations and preserving the (freshness) relations.  Because they involve the
same signature, the morphisms for fresh-swap-subst models (called fresh-swap-subst morphisms)
will be the same as those for fresh-subst-swap-models.
›

subsubsection ‹Preservation of the domains›

definition ipresIGWls where
"ipresIGWls h MOD MOD' ==
  s X. igWls MOD s X  igWls MOD' s (h X)"

definition ipresIGWlsAbs where
"ipresIGWlsAbs hA MOD MOD' ==
  us s A. igWlsAbs MOD (us,s) A  igWlsAbs MOD' (us,s) (hA A)"

definition ipresIGWlsAll where
"ipresIGWlsAll h hA MOD MOD' ==
 ipresIGWls h MOD MOD'   ipresIGWlsAbs hA MOD MOD'"

lemmas ipresIGWlsAll_defs = ipresIGWlsAll_def
ipresIGWls_def ipresIGWlsAbs_def

subsubsection ‹Preservation of the constructs›

definition ipresIGVar where
"ipresIGVar h MOD MOD' ==
  xs x. h (igVar MOD xs x) = igVar MOD' xs x"

definition ipresIGAbs where
"ipresIGAbs h hA MOD MOD' ==
  xs x s X. isInBar (xs,s)  igWls MOD s X 
             hA (igAbs MOD xs x X) = igAbs MOD' xs x (h X)"

definition ipresIGOp
where
"ipresIGOp h hA MOD MOD' ==
  delta inp binp.
   igWlsInp MOD delta inp  igWlsBinp MOD delta binp 
   h (igOp MOD delta inp binp) = igOp MOD' delta (lift h inp) (lift hA binp)"

definition ipresIGCons where
"ipresIGCons h hA MOD MOD' ==
 ipresIGVar h MOD MOD' 
 ipresIGAbs h hA MOD MOD' 
 ipresIGOp h hA MOD MOD'"

lemmas ipresIGCons_defs = ipresIGCons_def
ipresIGVar_def
ipresIGAbs_def
ipresIGOp_def

subsubsection ‹Preservation of freshness›

definition ipresIGFresh where
"ipresIGFresh h MOD MOD' ==
  ys y s X.
    igWls MOD s X 
    igFresh MOD ys y X  igFresh MOD' ys y (h X)"

definition ipresIGFreshAbs where
"ipresIGFreshAbs hA MOD MOD' ==
  ys y us s A.
    igWlsAbs MOD (us,s) A 
    igFreshAbs MOD ys y A  igFreshAbs MOD' ys y (hA A)"

definition ipresIGFreshAll where
"ipresIGFreshAll h hA MOD MOD' ==
 ipresIGFresh h MOD MOD'  ipresIGFreshAbs hA MOD MOD'"

lemmas ipresIGFreshAll_defs = ipresIGFreshAll_def
ipresIGFresh_def ipresIGFreshAbs_def

subsubsection ‹Preservation of swapping›

definition ipresIGSwap where
"ipresIGSwap h MOD MOD' ==
  zs z1 z2 s X.
    igWls MOD s X 
    h (igSwap MOD zs z1 z2 X) = igSwap MOD' zs z1 z2 (h X)"

definition ipresIGSwapAbs where
"ipresIGSwapAbs hA MOD MOD' ==
  zs z1 z2 us s A.
    igWlsAbs MOD (us,s) A 
    hA (igSwapAbs MOD zs z1 z2 A) = igSwapAbs MOD' zs z1 z2 (hA A)"

definition ipresIGSwapAll where
"ipresIGSwapAll h hA MOD MOD' ==
 ipresIGSwap h MOD MOD'  ipresIGSwapAbs hA MOD MOD'"

lemmas ipresIGSwapAll_defs = ipresIGSwapAll_def
ipresIGSwap_def ipresIGSwapAbs_def

subsubsection ‹Preservation of subst›

definition ipresIGSubst where
"ipresIGSubst h MOD MOD' ==
  ys Y y s X.
    igWls MOD (asSort ys) Y  igWls MOD s X 
    h (igSubst MOD ys Y y X) = igSubst MOD' ys (h Y) y (h X)"

definition ipresIGSubstAbs where
"ipresIGSubstAbs h hA MOD MOD' ==
  ys Y y us s A.
    igWls MOD (asSort ys) Y  igWlsAbs MOD (us,s) A 
    hA (igSubstAbs MOD ys Y y A) = igSubstAbs MOD' ys (h Y) y (hA A)"

definition ipresIGSubstAll where
"ipresIGSubstAll h hA MOD MOD' ==
 ipresIGSubst h MOD MOD' 
 ipresIGSubstAbs h hA MOD MOD'"

lemmas ipresIGSubstAll_defs = ipresIGSubstAll_def
ipresIGSubst_def ipresIGSubstAbs_def

subsubsection ‹Fresh-swap morphisms›

definition FSwImorph where
"FSwImorph h hA MOD MOD' ==
 ipresIGWlsAll h hA MOD MOD'  ipresIGCons h hA MOD MOD' 
 ipresIGFreshAll h hA MOD MOD'  ipresIGSwapAll h hA MOD MOD'"

lemmas FSwImorph_defs1 = FSwImorph_def
ipresIGWlsAll_def ipresIGCons_def
ipresIGFreshAll_def ipresIGSwapAll_def

lemmas FSwImorph_defs = FSwImorph_def
ipresIGWlsAll_defs ipresIGCons_defs
ipresIGFreshAll_defs ipresIGSwapAll_defs

subsubsection ‹Fresh-subst morphisms›

definition FSbImorph where
"FSbImorph h hA MOD MOD' ==
 ipresIGWlsAll h hA MOD MOD'  ipresIGCons h hA MOD MOD' 
 ipresIGFreshAll h hA MOD MOD'  ipresIGSubstAll h hA MOD MOD'"

lemmas FSbImorph_defs1 = FSbImorph_def
ipresIGWlsAll_def ipresIGCons_def
ipresIGFreshAll_def ipresIGSubstAll_def

lemmas FSbImorph_defs = FSbImorph_def
ipresIGWlsAll_defs ipresIGCons_defs
ipresIGFreshAll_defs ipresIGSubstAll_defs

subsubsection ‹Fresh-swap-subst morphisms›

(* Note that FSwSb-morphisms are also igood for FSbSw-models. *)

definition FSwSbImorph where
"FSwSbImorph h hA MOD MOD' ==
 FSwImorph h hA MOD MOD'  ipresIGSubstAll h hA MOD MOD'"

lemmas FSwSbImorph_defs1 = FSwSbImorph_def
FSwImorph_def ipresIGSubstAll_def

lemmas FSwSbImorph_defs = FSwSbImorph_def
FSwImorph_defs ipresIGSubstAll_defs

subsubsection ‹Basic facts›

text ‹FSwSb morphisms are the same as FSbSw morphisms:›

lemma FSwSbImorph_iff:
"FSwSbImorph h hA MOD MOD' =
 (FSbImorph h hA MOD MOD'  ipresIGSwapAll h hA MOD MOD')"
unfolding FSwSbImorph_def FSbImorph_def FSwImorph_def by auto

text ‹Some facts for free inpus:›

lemma igSwapInp_None[simp]:
"(igSwapInp MOD zs z1 z2 inp i = None) = (inp i = None)"
unfolding igSwapInp_def by(simp add: lift_None)

lemma igSubstInp_None[simp]:
"(igSubstInp MOD ys Y y inp i = None) = (inp i = None)"
unfolding igSubstInp_def by(simp add: lift_None)

lemma imp_igWlsInp:
"igWlsInp MOD delta inp  ipresIGWls h MOD MOD' 
  igWlsInp MOD' delta (lift h inp)"
by (simp add: igWlsInp_def ipresIGWls_def liftAll2_def lift_def 
sameDom_def split: option.splits)

corollary FSwImorph_igWlsInp:
assumes "igWlsInp MOD delta inp" and "FSwImorph h hA MOD MOD'"
shows "igWlsInp MOD' delta (lift h inp)"
using assms unfolding FSwImorph_def ipresIGWlsAll_def
using imp_igWlsInp by auto

corollary FSbImorph_igWlsInp:
assumes "igWlsInp MOD delta inp" and "FSbImorph h hA MOD MOD'"
shows "igWlsInp MOD' delta (lift h inp)"
using assms unfolding FSbImorph_def ipresIGWlsAll_def
using imp_igWlsInp by auto

lemma FSwSbImorph_igWlsInp:
assumes "igWlsInp MOD delta inp" and "FSwSbImorph h hA MOD MOD'"
shows "igWlsInp MOD' delta (lift h inp)"
using assms unfolding FSwSbImorph_def using FSwImorph_igWlsInp by auto

text ‹Similar facts for bound inpus:›

lemma igSwapBinp_None[simp]:
"(igSwapBinp MOD zs z1 z2 binp i = None) = (binp i = None)"
unfolding igSwapBinp_def by(simp add: lift_None)

lemma igSubstBinp_None[simp]:
"(igSubstBinp MOD ys Y y binp i = None) = (binp i = None)"
unfolding igSubstBinp_def by(simp add: lift_None)

lemma imp_igWlsBinp:
assumes *: "igWlsBinp MOD delta binp"
and **: "ipresIGWlsAbs hA MOD MOD'"
shows "igWlsBinp MOD' delta (lift hA binp)"
using assms by (simp add: igWlsBinp_def ipresIGWlsAbs_def liftAll2_def lift_def 
sameDom_def split: option.splits) 

corollary FSwImorph_igWlsBinp:
assumes "igWlsBinp MOD delta binp" and "FSwImorph h hA MOD MOD'"
shows "igWlsBinp MOD' delta (lift hA binp)"
using assms unfolding FSwImorph_def ipresIGWlsAll_def
using imp_igWlsBinp by auto

corollary FSbImorph_igWlsBinp:
assumes "igWlsBinp MOD delta binp" and "FSbImorph h hA MOD MOD'"
shows "igWlsBinp MOD' delta (lift hA binp)"
using assms unfolding FSbImorph_def ipresIGWlsAll_def
using imp_igWlsBinp by auto

lemma FSwSbImorph_igWlsBinp:
assumes "igWlsBinp MOD delta binp" and "FSwSbImorph h hA MOD MOD'"
shows "igWlsBinp MOD' delta (lift hA binp)"
using assms unfolding FSwSbImorph_def using FSwImorph_igWlsBinp by auto

lemmas input_igSwap_igSubst_None =
igSwapInp_None igSubstInp_None
igSwapBinp_None igSubstBinp_None

subsubsection ‹Identity and composition›

lemma id_FSwImorph: "FSwImorph id id MOD MOD"
unfolding FSwImorph_defs by auto

lemma id_FSbImorph: "FSbImorph id id MOD MOD"
unfolding FSbImorph_defs by auto

lemma id_FSwSbImorph: "FSwSbImorph id id MOD MOD"
unfolding FSwSbImorph_def apply(auto simp add: id_FSwImorph)
unfolding ipresIGSubstAll_defs by auto

lemma comp_ipresIGWls:
assumes "ipresIGWls h MOD MOD'" and "ipresIGWls h' MOD' MOD''"
shows "ipresIGWls (h' o h) MOD MOD''"
using assms unfolding ipresIGWls_def by auto

lemma comp_ipresIGWlsAbs:
assumes "ipresIGWlsAbs hA MOD MOD'" and "ipresIGWlsAbs hA' MOD' MOD''"
shows "ipresIGWlsAbs (hA' o hA) MOD MOD''"
using assms unfolding ipresIGWlsAbs_def by auto

lemma comp_ipresIGWlsAll:
assumes "ipresIGWlsAll h hA MOD MOD'" and "ipresIGWlsAll h' hA' MOD' MOD''"
shows "ipresIGWlsAll (h' o h) (hA' o hA) MOD MOD''"
using assms unfolding ipresIGWlsAll_def
using comp_ipresIGWls comp_ipresIGWlsAbs by auto

lemma comp_ipresIGVar:
assumes "ipresIGVar h MOD MOD'" and "ipresIGVar h' MOD' MOD''"
shows "ipresIGVar (h' o h) MOD MOD''"
using assms unfolding ipresIGVar_def by auto

lemma comp_ipresIGAbs:
assumes "ipresIGWls h MOD MOD'"
and "ipresIGAbs h hA MOD MOD'" and "ipresIGAbs h' hA' MOD' MOD''"
shows "ipresIGAbs (h' o h) (hA' o hA) MOD MOD''"
using assms unfolding ipresIGWls_def ipresIGAbs_def by fastforce

lemma comp_ipresIGOp:
assumes ipres: "ipresIGWls h MOD MOD'" and ipresAbs: "ipresIGWlsAbs hA MOD MOD'"
and h: "ipresIGOp h hA MOD MOD'" and h': "ipresIGOp h' hA' MOD' MOD''"
shows "ipresIGOp (h' o h) (hA' o hA) MOD MOD''"
using assms by (auto simp: imp_igWlsInp imp_igWlsBinp ipresIGOp_def lift_comp)
 
lemma comp_ipresIGCons:
assumes "ipresIGWlsAll h hA MOD MOD'"
and "ipresIGCons h hA MOD MOD'" and "ipresIGCons h' hA' MOD' MOD''"
shows "ipresIGCons (h' o h) (hA' o hA) MOD MOD''"
using assms unfolding ipresIGWlsAll_def ipresIGCons_def
using comp_ipresIGVar comp_ipresIGAbs comp_ipresIGOp by auto

lemma comp_ipresIGFresh:
assumes "ipresIGWls h MOD MOD'"
and "ipresIGFresh h MOD MOD'" and "ipresIGFresh h' MOD' MOD''"
shows "ipresIGFresh (h' o h) MOD MOD''"
using assms unfolding ipresIGWls_def ipresIGFresh_def by fastforce

lemma comp_ipresIGFreshAbs:
assumes "ipresIGWlsAbs hA MOD MOD'"
and "ipresIGFreshAbs hA MOD MOD'" and "ipresIGFreshAbs hA' MOD' MOD''"
shows "ipresIGFreshAbs (hA' o hA) MOD MOD''"
using assms unfolding ipresIGWlsAbs_def ipresIGFreshAbs_def by fastforce

lemma comp_ipresIGFreshAll:
assumes "ipresIGWlsAll h hA MOD MOD'"
and "ipresIGFreshAll h hA MOD MOD'" and "ipresIGFreshAll h' hA'  MOD' MOD''"
shows "ipresIGFreshAll (h' o h) (hA' o hA) MOD MOD''"
using assms
unfolding ipresIGWlsAll_def ipresIGFreshAll_def
using comp_ipresIGFresh comp_ipresIGFreshAbs by auto

lemma comp_ipresIGSwap:
assumes "ipresIGWls h MOD MOD'"
and "ipresIGSwap h MOD MOD'" and "ipresIGSwap h' MOD' MOD''"
shows "ipresIGSwap (h' o h) MOD MOD''"
using assms unfolding ipresIGWls_def ipresIGSwap_def by fastforce

lemma comp_ipresIGSwapAbs:
assumes "ipresIGWlsAbs hA MOD MOD'"
and "ipresIGSwapAbs hA MOD MOD'" and "ipresIGSwapAbs hA' MOD' MOD''"
shows "ipresIGSwapAbs (hA' o hA) MOD MOD''"
using assms unfolding ipresIGWlsAbs_def ipresIGSwapAbs_def by fastforce

lemma comp_ipresIGSwapAll:
assumes "ipresIGWlsAll h hA MOD MOD'"
and "ipresIGSwapAll h hA MOD MOD'" and "ipresIGSwapAll h' hA'  MOD' MOD''"
shows "ipresIGSwapAll (h' o h) (hA' o hA) MOD MOD''"
using assms
unfolding ipresIGWlsAll_def ipresIGSwapAll_def
using comp_ipresIGSwap comp_ipresIGSwapAbs by auto

lemma comp_ipresIGSubst:
assumes "ipresIGWls h MOD MOD'"
and "ipresIGSubst h MOD MOD'" and "ipresIGSubst h' MOD' MOD''"
shows "ipresIGSubst (h' o h) MOD MOD''"
using assms unfolding ipresIGWls_def ipresIGSubst_def
apply auto by blast

lemma comp_ipresIGSubstAbs:
assumes *: "igWlsAbsIsInBar MOD"
and h: "ipresIGWls h MOD MOD'" and hA: "ipresIGWlsAbs hA MOD MOD'"
and hhA: "ipresIGSubstAbs h hA MOD MOD'" and h'hA': "ipresIGSubstAbs h' hA' MOD' MOD''"
shows "ipresIGSubstAbs (h' o h) (hA' o hA) MOD MOD''"
using assms by(fastforce simp: igWlsAbsIsInBar_def 
ipresIGSubstAbs_def ipresIGWls_def ipresIGWlsAbs_def) 
 
lemma comp_ipresIGSubstAll:
assumes "igWlsAbsIsInBar MOD"
and "ipresIGWlsAll h hA MOD MOD'"
and "ipresIGSubstAll h hA MOD MOD'" and "ipresIGSubstAll h' hA'  MOD' MOD''"
shows "ipresIGSubstAll (h' o h) (hA' o hA) MOD MOD''"
using assms unfolding ipresIGWlsAll_def ipresIGSubstAll_def
using comp_ipresIGSubst comp_ipresIGSubstAbs by auto

lemma comp_FSwImorph:
assumes *: "FSwImorph h hA MOD MOD'" and **: "FSwImorph h' hA' MOD' MOD''"
shows "FSwImorph (h' o h) (hA' o hA) MOD MOD''"
using assms unfolding FSwImorph_def
using comp_ipresIGWlsAll comp_ipresIGCons
comp_ipresIGFreshAll comp_ipresIGSwapAll by auto

lemma comp_FSbImorph:
assumes "igWlsAbsIsInBar MOD"
and "FSbImorph h hA MOD MOD'" and "FSbImorph h' hA' MOD' MOD''"
shows "FSbImorph (h' o h) (hA' o hA) MOD MOD''"
using assms unfolding FSbImorph_def
using comp_ipresIGWlsAll comp_ipresIGCons
comp_ipresIGFreshAll comp_ipresIGSubstAll by auto

lemma comp_FSwSbImorph:
assumes "igWlsAbsIsInBar MOD"
and "FSwSbImorph h hA MOD MOD'" and "FSwSbImorph h' hA' MOD' MOD''"
shows "FSwSbImorph (h' o h) (hA' o hA) MOD MOD''"
using assms unfolding FSwSbImorph_def  
using comp_FSwImorph FSwImorph_def comp_ipresIGSubstAll FixSyn_axioms by blast

subsection ‹The term model›

text ‹We show that terms form fresh-swap-subst and fresh-subst-swap models.›

subsubsection ‹Definitions and simplification rules›

definition termMOD where
"termMOD ==
 igWls = wls, igWlsAbs = wlsAbs,
  igVar = Var, igAbs = Abs, igOp = Op,
  igFresh = fresh, igFreshAbs = freshAbs,
  igSwap = swap, igSwapAbs = swapAbs,
  igSubst = subst, igSubstAbs = substAbs"

lemma igWls_termMOD[simp]: "igWls termMOD = wls"
unfolding termMOD_def by simp

lemma igWlsAbs_termMOD[simp]: "igWlsAbs termMOD = wlsAbs"
unfolding termMOD_def by simp

lemma igWlsInp_termMOD_wlsInp[simp]:
"igWlsInp termMOD delta inp = wlsInp delta inp"
unfolding igWlsInp_def wlsInp_iff by simp

lemma igWlsBinp_termMOD_wlsBinp[simp]:
"igWlsBinp termMOD delta binp = wlsBinp delta binp"
unfolding igWlsBinp_def wlsBinp_iff by simp

lemmas igWlsAll_termMOD_simps =
igWls_termMOD igWlsAbs_termMOD
igWlsInp_termMOD_wlsInp igWlsBinp_termMOD_wlsBinp

lemma igVar_termMOD[simp]: "igVar termMOD = Var"
unfolding termMOD_def by simp

lemma igAbs_termMOD[simp]: "igAbs termMOD = Abs"
unfolding termMOD_def by simp

lemma igOp_termMOD[simp]: "igOp termMOD = Op"
unfolding termMOD_def by simp

lemmas igCons_termMOD_simps =
igVar_termMOD igAbs_termMOD igOp_termMOD

lemma igFresh_termMOD[simp]: "igFresh termMOD = fresh"
unfolding termMOD_def by simp

lemma igFreshAbs_termMOD[simp]: "igFreshAbs termMOD = freshAbs"
unfolding termMOD_def by simp

lemma igFreshInp_termMOD[simp]: "igFreshInp termMOD = freshInp"
unfolding igFreshInp_def[abs_def] freshInp_def[abs_def] by simp

lemma igFreshBinp_termMOD[simp]: "igFreshBinp termMOD = freshBinp"
unfolding igFreshBinp_def[abs_def] freshBinp_def[abs_def] by simp

lemmas igFreshAll_termMOD_simps =
igFresh_termMOD igFreshAbs_termMOD
igFreshInp_termMOD igFreshBinp_termMOD

lemma igSwap_termMOD[simp]: "igSwap termMOD = swap"
unfolding termMOD_def by simp

lemma igSwapAbs_termMOD[simp]: "igSwapAbs termMOD = swapAbs"
unfolding termMOD_def by simp

lemma igSwapInp_termMOD[simp]: "igSwapInp termMOD = swapInp"
unfolding igSwapInp_def[abs_def] swapInp_def[abs_def] by simp

lemma igSwapBinp_termMOD[simp]: "igSwapBinp termMOD = swapBinp"
unfolding igSwapBinp_def[abs_def] swapBinp_def[abs_def] by simp

lemmas igSwapAll_termMOD_simps =
igSwap_termMOD igSwapAbs_termMOD
igSwapInp_termMOD igSwapBinp_termMOD

lemma igSubst_termMOD[simp]: "igSubst termMOD = subst"
unfolding termMOD_def by simp

lemma igSubstAbs_termMOD[simp]: "igSubstAbs termMOD = substAbs"
unfolding termMOD_def by simp

lemma igSubstInp_termMOD[simp]: "igSubstInp termMOD = substInp"
by (simp add: igSubstInp_def[abs_def] substInp_def[abs_def]  
psubstInp_def[abs_def] subst_def)

lemma igSubstBinp_termMOD[simp]: "igSubstBinp termMOD = substBinp"
by (simp add: igSubstBinp_def[abs_def] substBinp_def[abs_def]  
psubstBinp_def[abs_def] substAbs_def)

lemmas igSubstAll_termMOD_simps =
igSubst_termMOD igSubstAbs_termMOD
igSubstInp_termMOD igSubstBinp_termMOD

lemmas structure_termMOD_simps =
igWlsAll_termMOD_simps
igFreshAll_termMOD_simps
igSwapAll_termMOD_simps
igSubstAll_termMOD_simps

subsubsection ‹Well-sortedness of the term model›

text‹Domains are disjoint:›

lemma termMOD_igWlsDisj: "igWlsDisj termMOD"
unfolding igWlsDisj_def using wls_disjoint by auto

lemma termMOD_igWlsAbsDisj: "igWlsAbsDisj termMOD"
unfolding igWlsAbsDisj_def using wlsAbs_disjoint by auto

lemma termMOD_igWlsAllDisj: "igWlsAllDisj termMOD"
unfolding igWlsAllDisj_def
using termMOD_igWlsDisj termMOD_igWlsAbsDisj by simp

text ‹Abstraction domains inhabited only within bound arities:›

lemma termMOD_igWlsAbsIsInBar: "igWlsAbsIsInBar termMOD"
unfolding igWlsAbsIsInBar_def using wlsAbs_nchotomy by simp

text‹The syntactic constructs preserve the domains:›

lemma termMOD_igVarIPresIGWls: "igVarIPresIGWls termMOD"
unfolding igVarIPresIGWls_def by simp

lemma termMOD_igAbsIPresIGWls: "igAbsIPresIGWls termMOD"
unfolding igAbsIPresIGWls_def by simp

lemma termMOD_igOpIPresIGWls: "igOpIPresIGWls termMOD"
unfolding igOpIPresIGWls_def by simp

lemma termMOD_igConsIPresIGWls: "igConsIPresIGWls termMOD"
unfolding igConsIPresIGWls_def
using termMOD_igVarIPresIGWls termMOD_igAbsIPresIGWls termMOD_igOpIPresIGWls
by auto

text‹Swap preserves the domains:›

lemma termMOD_igSwapIPresIGWls: "igSwapIPresIGWls termMOD"
unfolding igSwapIPresIGWls_def by simp

lemma termMOD_igSwapAbsIPresIGWlsAbs: "igSwapAbsIPresIGWlsAbs termMOD"
unfolding igSwapAbsIPresIGWlsAbs_def by simp

lemma termMOD_igSwapAllIPresIGWlsAll: "igSwapAllIPresIGWlsAll termMOD"
unfolding igSwapAllIPresIGWlsAll_def
using termMOD_igSwapIPresIGWls termMOD_igSwapAbsIPresIGWlsAbs by auto

text‹``Subst" preserves the domains:›

lemma termMOD_igSubstIPresIGWls: "igSubstIPresIGWls termMOD"
unfolding igSubstIPresIGWls_def by simp

lemma termMOD_igSubstAbsIPresIGWlsAbs: "igSubstAbsIPresIGWlsAbs termMOD"
unfolding igSubstAbsIPresIGWlsAbs_def by simp

lemma termMOD_igSubstAllIPresIGWlsAll: "igSubstAllIPresIGWlsAll termMOD"
unfolding igSubstAllIPresIGWlsAll_def
using termMOD_igSubstIPresIGWls termMOD_igSubstAbsIPresIGWlsAbs by auto

text‹The ``fresh" clauses hold:›

lemma termMOD_igFreshIGVar: "igFreshIGVar termMOD"
unfolding igFreshIGVar_def by simp

lemma termMOD_igFreshIGAbs1: "igFreshIGAbs1 termMOD"
unfolding igFreshIGAbs1_def by auto

lemma termMOD_igFreshIGAbs2: "igFreshIGAbs2 termMOD"
unfolding igFreshIGAbs2_def by auto

lemma termMOD_igFreshIGOp: "igFreshIGOp termMOD"
unfolding igFreshIGOp_def by simp

lemma termMOD_igFreshCls: "igFreshCls termMOD"
unfolding igFreshCls_def
using termMOD_igFreshIGVar termMOD_igFreshIGAbs1 termMOD_igFreshIGAbs2 termMOD_igFreshIGOp
by simp

text‹The ``swap" clauses hold:›

lemma termMOD_igSwapIGVar: "igSwapIGVar termMOD"
unfolding igSwapIGVar_def by simp

lemma termMOD_igSwapIGAbs: "igSwapIGAbs termMOD"
unfolding igSwapIGAbs_def by auto

lemma termMOD_igSwapIGOp: "igSwapIGOp termMOD"
unfolding igSwapIGOp_def by simp

lemma termMOD_igSwapCls: "igSwapCls termMOD"
unfolding igSwapCls_def
using termMOD_igSwapIGVar termMOD_igSwapIGAbs termMOD_igSwapIGOp by simp

text‹The ``subst" clauses hold:›

lemma termMOD_igSubstIGVar1: "igSubstIGVar1 termMOD"
unfolding igSubstIGVar1_def by auto

lemma termMOD_igSubstIGVar2: "igSubstIGVar2 termMOD"
unfolding igSubstIGVar2_def by auto

lemma termMOD_igSubstIGAbs: "igSubstIGAbs termMOD"
unfolding igSubstIGAbs_def by auto

lemma termMOD_igSubstIGOp: "igSubstIGOp termMOD"
unfolding igSubstIGOp_def by simp

lemma termMOD_igSubstCls: "igSubstCls termMOD"
unfolding igSubstCls_def
using termMOD_igSubstIGVar1 termMOD_igSubstIGVar2
termMOD_igSubstIGAbs termMOD_igSubstIGOp by simp

text‹The swap-congruence clause for abstractions holds:›

lemma termMOD_igAbsCongS: "igAbsCongS termMOD" 
unfolding igAbsCongS_def using wls_Abs_swap_cong 
by (metis igAbs_termMOD igFresh_termMOD igSwap_termMOD igWls_termMOD) 
 

text‹The subst-renaming clause for abstractions holds:›

lemma termMOD_igAbsRen: "igAbsRen termMOD"
unfolding igAbsRen_def by auto

lemma termMOD_iwlsFSw: "iwlsFSw termMOD"
unfolding iwlsFSw_def
using
termMOD_igWlsAllDisj termMOD_igWlsAbsIsInBar
termMOD_igConsIPresIGWls termMOD_igSwapAllIPresIGWlsAll
termMOD_igFreshCls termMOD_igSwapCls termMOD_igAbsCongS
by auto

lemma termMOD_iwlsFSb: "iwlsFSb termMOD"
unfolding iwlsFSb_def
using
termMOD_igWlsAllDisj termMOD_igWlsAbsIsInBar
termMOD_igConsIPresIGWls termMOD_igSubstAllIPresIGWlsAll
termMOD_igFreshCls termMOD_igSubstCls termMOD_igAbsRen
by auto

lemma termMOD_iwlsFSwSb: "iwlsFSwSb termMOD"
unfolding iwlsFSwSb_def
using termMOD_iwlsFSw termMOD_igSubstAllIPresIGWlsAll termMOD_igSubstCls
by simp

lemma termMOD_iwlsFSbSw: "iwlsFSbSw termMOD"
unfolding iwlsFSbSw_def
using termMOD_iwlsFSb termMOD_igSwapAllIPresIGWlsAll termMOD_igSwapCls
by simp

subsubsection ‹Direct description of morphisms from the term models›

(* We merely employ predicates referring directly to terms rather than
mediating through the model structure of terms. *)

definition ipresWls where
"ipresWls h MOD ==
  s X. wls s X  igWls MOD s (h X)"

lemma ipresIGWls_termMOD[simp]:
"ipresIGWls h termMOD MOD = ipresWls h MOD"
unfolding ipresIGWls_def ipresWls_def by simp

definition ipresWlsAbs where
"ipresWlsAbs hA MOD ==
  us s A. wlsAbs (us,s) A  igWlsAbs MOD (us,s) (hA A)"

lemma ipresIGWlsAbs_termMOD[simp]:
"ipresIGWlsAbs hA termMOD MOD = ipresWlsAbs hA MOD"
unfolding ipresIGWlsAbs_def ipresWlsAbs_def by simp

definition ipresWlsAll where
"ipresWlsAll h hA MOD ==
 ipresWls h MOD  ipresWlsAbs hA MOD"

lemmas ipresWlsAll_defs = ipresWlsAll_def
ipresWls_def ipresWlsAbs_def

lemma ipresIGWlsAll_termMOD[simp]:
"ipresIGWlsAll h hA termMOD MOD = ipresWlsAll h hA MOD"
unfolding ipresIGWlsAll_def ipresWlsAll_def by simp

lemmas ipresIGWlsAll_termMOD_simps =
ipresIGWls_termMOD ipresIGWlsAbs_termMOD ipresIGWlsAll_termMOD

definition ipresVar where
"ipresVar h MOD ==
  xs x. h (Var xs x) = igVar MOD xs x"

lemma ipresIGVar_termMOD[simp]:
"ipresIGVar h termMOD MOD = ipresVar h MOD"
unfolding ipresIGVar_def ipresVar_def by simp

definition ipresAbs where
"ipresAbs h hA MOD ==
  xs x s X. isInBar (xs,s)  wls s X  hA (Abs xs x X) = igAbs MOD xs x (h X)"

lemma ipresIGAbs_termMOD[simp]:
"ipresIGAbs h hA termMOD MOD = ipresAbs h hA MOD"
unfolding ipresIGAbs_def ipresAbs_def by simp

definition ipresOp where
"ipresOp h hA MOD ==
  delta inp binp.
    wlsInp delta inp  wlsBinp delta binp 
    h (Op delta inp binp) =
    igOp MOD delta (lift h inp) (lift hA binp)"

lemma ipresIGOp_termMOD[simp]:
"ipresIGOp h hA termMOD MOD = ipresOp h hA MOD"
unfolding ipresIGOp_def ipresOp_def by simp

definition ipresCons where
"ipresCons h hA MOD ==
 ipresVar h MOD 
 ipresAbs h hA MOD 
 ipresOp h hA MOD"

lemmas ipresCons_defs = ipresCons_def
ipresVar_def
ipresAbs_def
ipresOp_def

lemma ipresIGCons_termMOD[simp]:
"ipresIGCons h hA termMOD MOD = ipresCons h hA MOD"
unfolding ipresIGCons_def ipresCons_def by simp

lemmas ipresIGCons_termMOD_simps =
ipresIGVar_termMOD ipresIGAbs_termMOD ipresIGOp_termMOD
ipresIGCons_termMOD

definition ipresFresh where
"ipresFresh h MOD ==
  ys y s X.
    wls s X 
    fresh ys y X  igFresh MOD ys y (h X)"

lemma ipresIGFresh_termMOD[simp]:
"ipresIGFresh h termMOD MOD = ipresFresh h MOD"
unfolding ipresIGFresh_def ipresFresh_def by simp

definition ipresFreshAbs where
"ipresFreshAbs hA MOD ==
  ys y us s A.
    wlsAbs (us,s) A 
    freshAbs ys y A  igFreshAbs MOD ys y (hA A)"

lemma ipresIGFreshAbs_termMOD[simp]:
"ipresIGFreshAbs hA termMOD MOD = ipresFreshAbs hA MOD"
unfolding ipresIGFreshAbs_def ipresFreshAbs_def by simp

definition ipresFreshAll where
"ipresFreshAll h hA MOD ==
 ipresFresh h MOD  ipresFreshAbs hA MOD"

lemmas ipresFreshAll_defs = ipresFreshAll_def
ipresFresh_def ipresFreshAbs_def

lemma ipresIGFreshAll_termMOD[simp]:
"ipresIGFreshAll h hA termMOD MOD = ipresFreshAll h hA MOD"
unfolding ipresIGFreshAll_def ipresFreshAll_def by simp

lemmas ipresIGFreshAll_termMOD_simps =
ipresIGFresh_termMOD ipresIGFreshAbs_termMOD ipresIGFreshAll_termMOD

definition ipresSwap where
"ipresSwap h MOD ==
  zs z1 z2 s X.
    wls s X 
    h (X #[z1  z2]_zs) = igSwap MOD zs z1 z2 (h X)"

lemma ipresIGSwap_termMOD[simp]:
"ipresIGSwap h termMOD MOD = ipresSwap h MOD"
unfolding ipresIGSwap_def ipresSwap_def by simp

definition ipresSwapAbs where
"ipresSwapAbs hA MOD ==
  zs z1 z2 us s A.
    wlsAbs (us,s) A 
    hA (A $[z1  z2]_zs) = igSwapAbs MOD zs z1 z2 (hA A)"

lemma ipresIGSwapAbs_termMOD[simp]:
"ipresIGSwapAbs hA termMOD MOD = ipresSwapAbs hA MOD"
unfolding ipresIGSwapAbs_def ipresSwapAbs_def by simp

definition ipresSwapAll where
"ipresSwapAll h hA MOD ==
 ipresSwap h MOD  ipresSwapAbs hA MOD"

lemmas ipresSwapAll_defs = ipresSwapAll_def
ipresSwap_def ipresSwapAbs_def

lemma ipresIGSwapAll_termMOD[simp]:
"ipresIGSwapAll h hA termMOD MOD = ipresSwapAll h hA MOD"
unfolding ipresIGSwapAll_def ipresSwapAll_def by simp

lemmas ipresIGSwapAll_termMOD_simps =
ipresIGSwap_termMOD ipresIGSwapAbs_termMOD ipresIGSwapAll_termMOD

definition ipresSubst where
"ipresSubst h MOD ==
  ys Y y s X.
    wls (asSort ys) Y  wls s X 
    h (subst ys Y y X) = igSubst MOD ys (h Y) y (h X)"

lemma ipresIGSubst_termMOD[simp]:
"ipresIGSubst h termMOD MOD = ipresSubst h MOD"
unfolding ipresIGSubst_def ipresSubst_def by simp

definition ipresSubstAbs where
"ipresSubstAbs h hA MOD ==
  ys Y y us s A.
    wls (asSort ys) Y  wlsAbs (us,s) A 
    hA (A $[Y / y]_ys) = igSubstAbs MOD ys (h Y) y (hA A)"

lemma ipresIGSubstAbs_termMOD[simp]:
"ipresIGSubstAbs h hA termMOD MOD = ipresSubstAbs h hA MOD"
unfolding ipresIGSubstAbs_def ipresSubstAbs_def by simp

definition ipresSubstAll where
"ipresSubstAll h hA MOD ==
 ipresSubst h MOD  ipresSubstAbs h hA MOD"

lemmas ipresSubstAll_defs = ipresSubstAll_def
ipresSubst_def ipresSubstAbs_def

lemma ipresIGSubstAll_termMOD[simp]:
"ipresIGSubstAll h hA termMOD MOD = ipresSubstAll h hA MOD"
unfolding ipresIGSubstAll_def ipresSubstAll_def by simp

lemmas ipresIGSubstAll_termMOD_simps =
ipresIGSubst_termMOD ipresIGSubstAbs_termMOD ipresIGSubstAll_termMOD

definition termFSwImorph where
"termFSwImorph h hA MOD ==
 ipresWlsAll h hA MOD  ipresCons h hA MOD 
 ipresFreshAll h hA MOD  ipresSwapAll h hA MOD"

lemmas termFSwImorph_defs1 = termFSwImorph_def
ipresWlsAll_def ipresCons_def
ipresFreshAll_def ipresSwapAll_def

lemmas termFSwImorph_defs = termFSwImorph_def
ipresWlsAll_defs ipresCons_defs
ipresFreshAll_defs ipresSwapAll_defs

lemma FSwImorph_termMOD[simp]:
"FSwImorph h hA termMOD MOD = termFSwImorph h hA MOD"
unfolding FSwImorph_def termFSwImorph_def by simp

definition termFSbImorph where
"termFSbImorph h hA MOD ==
 ipresWlsAll h hA MOD  ipresCons h hA MOD 
 ipresFreshAll h hA MOD  ipresSubstAll h hA MOD"

lemmas termFSbImorph_defs1 = termFSbImorph_def
ipresWlsAll_def ipresCons_def
ipresFreshAll_def ipresSubstAll_def

lemmas termFSbImorph_defs = termFSbImorph_def
ipresWlsAll_defs ipresCons_defs
ipresFreshAll_defs ipresSubstAll_defs

lemma FSbImorph_termMOD[simp]:
"FSbImorph h hA termMOD MOD = termFSbImorph h hA MOD"
unfolding FSbImorph_def termFSbImorph_def by simp

definition termFSwSbImorph where
"termFSwSbImorph h hA MOD ==
 termFSwImorph h hA MOD  ipresSubstAll h hA MOD"

lemmas termFSwSbImorph_defs1 = termFSwSbImorph_def
termFSwImorph_def ipresSubstAll_def

lemmas termFSwSbImorph_defs = termFSwSbImorph_def
termFSwImorph_defs ipresSubstAll_defs

text ‹Term FSwSb morphisms are the same as FSbSw morphisms:›

lemma termFSwSbImorph_iff:
"termFSwSbImorph h hA MOD =
 (termFSbImorph h hA MOD  ipresSwapAll h hA MOD)"
unfolding termFSwSbImorph_def termFSwImorph_def termFSbImorph_def ipresSubstAll_def
unfolding FSwSbImorph_def FSbImorph_def FSwImorph_def by auto

lemma FSwSbImorph_termMOD[simp]:
"FSwSbImorph h hA termMOD MOD = termFSwSbImorph h hA MOD"
unfolding FSwSbImorph_def termFSwSbImorph_def by simp

lemma ipresWls_wlsInp:
assumes "wlsInp delta inp" and "ipresWls h MOD"
shows "igWlsInp MOD delta (lift h inp)"
using assms imp_igWlsInp[of termMOD delta inp h MOD] by auto

lemma termFSwImorph_wlsInp:
assumes "wlsInp delta inp" and "termFSwImorph h hA MOD"
shows "igWlsInp MOD delta (lift h inp)"
using assms FSwImorph_igWlsInp[of termMOD delta inp h hA MOD] by auto

lemma termFSwSbImorph_wlsInp:
assumes "wlsInp delta inp" and "termFSwSbImorph h hA MOD"
shows "igWlsInp MOD delta (lift h inp)"
using assms FSwSbImorph_igWlsInp[of termMOD delta inp h hA MOD] by auto

lemma ipresWls_wlsBinp:
assumes "wlsBinp delta binp" and "ipresWlsAbs hA MOD"
shows "igWlsBinp MOD delta (lift hA binp)"
using assms imp_igWlsBinp[of termMOD delta binp hA MOD] by auto

lemma termFSwImorph_wlsBinp:
assumes "wlsBinp delta binp" and "termFSwImorph h hA MOD"
shows "igWlsBinp MOD delta (lift hA binp)"
using assms FSwImorph_igWlsBinp[of termMOD delta binp h hA MOD] by auto

lemma termFSwSbImorph_wlsBinp:
assumes "wlsBinp delta binp" and "termFSwSbImorph h hA MOD"
shows "igWlsBinp MOD delta (lift hA binp)"
using assms FSwSbImorph_igWlsBinp[of termMOD delta binp h hA MOD] by auto

lemma id_termFSwImorph: "termFSwImorph id id termMOD"
using id_FSwImorph[of termMOD] by simp

lemma id_termFSbImorph: "termFSbImorph id id termMOD"
using id_FSbImorph[of termMOD] by simp

lemma id_termFSwSbImorph: "termFSwSbImorph id id termMOD"
using id_FSwSbImorph[of termMOD] by simp

lemma comp_termFSwImorph:
assumes *: "termFSwImorph h hA MOD" and **: "FSwImorph h' hA' MOD MOD'"
shows "termFSwImorph (h' o h) (hA' o hA) MOD'"
using assms comp_FSwImorph[of h hA termMOD MOD h' hA' MOD'] by auto

lemma comp_termFSbImorph:
assumes *: "termFSbImorph h hA MOD" and **: "FSbImorph h' hA' MOD MOD'"
shows "termFSbImorph (h' o h) (hA' o hA) MOD'"
using assms comp_FSbImorph[of termMOD h hA MOD h' hA' MOD']
      termMOD_igWlsAbsIsInBar by auto

lemma comp_termFSwSbImorph:
assumes *: "termFSwSbImorph h hA MOD" and **: "FSwSbImorph h' hA' MOD MOD'"
shows "termFSwSbImorph (h' o h) (hA' o hA) MOD'"
using assms comp_FSwSbImorph[of termMOD h hA MOD h' hA' MOD']
      termMOD_igWlsAbsIsInBar by auto

lemmas mapFrom_termMOD_simps =
ipresIGWlsAll_termMOD_simps
ipresIGCons_termMOD_simps
ipresIGFreshAll_termMOD_simps
ipresIGSwapAll_termMOD_simps
ipresIGSubstAll_termMOD_simps
FSwImorph_termMOD FSbImorph_termMOD FSwSbImorph_termMOD

lemmas termMOD_simps =
structure_termMOD_simps mapFrom_termMOD_simps

subsubsection
‹Sufficient criteria for being a morphism
   to a well-sorted model (of various kinds)›

text‹In a nutshell: in these cases, we only need to check preservation of the
  syntactic constructs, ``ipresCons".›

lemma ipresCons_imp_ipresWlsAll:
assumes *: "ipresCons h hA MOD" and **: "igConsIPresIGWls MOD"
shows "ipresWlsAll h hA MOD"
proof-
  {fix s X us s' A
   have "(wls s X  igWls MOD s (h X)) 
         (wlsAbs (us,s') A  igWlsAbs MOD (us,s') (hA A))"
   proof(induction rule: wls_rawInduct)
     case (Var xs x)
     then show ?case 
     by (metis assms igConsIPresIGWls_def igVarIPresIGWls_def ipresCons_def ipresVar_def)
   next
     case (Op delta inp binp)
     have "igWlsInp MOD delta (lift h inp)  igWlsBinp MOD delta (lift hA binp)"
     using Op unfolding igWlsInp_def igWlsBinp_def wlsInp_iff wlsBinp_iff  
     by simp (simp add: liftAll2_def lift_def split: option.splits)
     hence "igWls MOD (stOf delta) (igOp MOD delta (lift h inp) (lift hA binp))"
     using ** unfolding igConsIPresIGWls_def igOpIPresIGWls_def by simp
     thus ?case using Op * unfolding ipresCons_def ipresOp_def by simp
   next
     case (Abs s xs x X)
     then show ?case  
     by (metis assms igAbsIPresIGWls_def igConsIPresIGWls_def ipresAbs_def ipresCons_def)
   qed 
  }
  thus ?thesis unfolding ipresWlsAll_defs by simp
qed

lemma ipresCons_imp_ipresFreshAll:
assumes *: "ipresCons h hA MOD" and **: "igFreshCls MOD"
and "igConsIPresIGWls MOD"
shows "ipresFreshAll h hA MOD"
proof-
  have ***: "ipresWlsAll h hA MOD"
  using assms ipresCons_imp_ipresWlsAll by auto
  hence ****:
  " delta inp. wlsInp delta inp  igWlsInp MOD delta (lift h inp)"
  " delta binp. wlsBinp delta binp  igWlsBinp MOD delta (lift hA binp)"
  unfolding ipresWlsAll_def using ipresWls_wlsInp ipresWls_wlsBinp by auto
  (*  *)
  {fix s X us s' A ys y
   have "(wls s X  fresh ys y X  igFresh MOD ys y (h X)) 
         (wlsAbs (us,s') A  freshAbs ys y A  igFreshAbs MOD ys y (hA A))"
   proof(induction rule: wls_rawInduct)
     case (Var xs x)
     then show ?case 
     by (metis * ** fresh_Var_simp igFreshCls_def igFreshIGVar_def ipresCons_def ipresVar_def)
   next
     case (Op delta inp binp) 
     show ?case proof safe
       assume y_fresh: "fresh ys y (Op delta inp binp)"
       {fix i X assume inp: "inp i = Some X"
        then obtain s where "arOf delta i = Some s" 
        using Op unfolding wlsInp_iff sameDom_def by fastforce
        hence "igFresh MOD ys y (h X)"
        using Op.IH y_fresh inp unfolding freshInp_def liftAll_def liftAll2_def 
        by (metis freshInp_def liftAll_def wls_fresh_Op_simp)
       }
       moreover
       {fix i A assume binp: "binp i = Some A"
        then obtain us_s where "barOf delta i = Some us_s"
        using Op unfolding wlsBinp_iff sameDom_def by force
        hence "igFreshAbs MOD ys y (hA A)"
        using Op.IH y_fresh binp unfolding freshBinp_def liftAll_def liftAll2_def 
        by simp (metis (no_types, hide_lams) freshBinp_def liftAll_def old.prod.exhaust)
       }
       ultimately have "igFreshInp MOD ys y (lift h inp)  igFreshBinp MOD ys y (lift hA binp)"
       unfolding igFreshInp_def igFreshBinp_def liftAll_lift_comp unfolding liftAll_def by auto        
       moreover have "igWlsInp MOD delta (lift h inp)  igWlsBinp MOD delta (lift hA binp)"
       using Op **** by simp
       ultimately have "igFresh MOD ys y (igOp MOD delta (lift h inp) (lift hA binp))"
       using ** unfolding igFreshCls_def igFreshIGOp_def by simp
       thus "igFresh MOD ys y (h (Op delta inp binp))"
       using Op * unfolding ipresCons_def ipresOp_def by simp
     qed
   next
     case (Abs s xs x X) 
     hence hX_wls: "igWls MOD s (h X)"
     using *** unfolding ipresWlsAll_def ipresWls_def by simp
     thus ?case  
     using Abs assms by (cases "ys = xs  y = x")
     (simp_all add: igFreshCls_def igFreshIGAbs1_def igFreshIGAbs2_def ipresAbs_def ipresCons_def)
   qed 
  }
  thus ?thesis unfolding ipresFreshAll_defs by auto
qed

lemma ipresCons_imp_ipresSwapAll:
assumes *: "ipresCons h hA MOD" and **: "igSwapCls MOD"
and "igConsIPresIGWls MOD"
shows "ipresSwapAll h hA MOD"
proof-
  have ***: "ipresWlsAll h hA MOD"
  using assms ipresCons_imp_ipresWlsAll by auto
  hence ****:
  " delta inp. wlsInp delta inp  igWlsInp MOD delta (lift h inp)"
  " delta binp. wlsBinp delta binp  igWlsBinp MOD delta (lift hA binp)"
  unfolding ipresWlsAll_def using ipresWls_wlsInp ipresWls_wlsBinp by auto
  (*  *)
  {fix s X us s' A zs z1 z2
   have "(wls s X  h (swap zs z1 z2 X) = igSwap MOD zs z1 z2 (h X)) 
         (wlsAbs (us,s') A  hA (swapAbs zs z1 z2 A) = igSwapAbs MOD zs z1 z2 (hA A))"
   proof(induction rule: wls_rawInduct)
     case (Var xs x)
     then show ?case  
     by (metis "*" "**" igSwapCls_def igSwapIGVar_def ipresCons_def ipresVar_def swap_Var_simp)
   next
     case (Op delta inp binp)
     let ?inpsw = "swapInp zs z1 z2 inp"   let ?binpsw = "swapBinp zs z1 z2 binp"
     let ?Left = "h (Op delta ?inpsw ?binpsw)"
     let ?Right = "igSwap MOD zs z1 z2 (h (Op delta inp binp))" 
     have wlsLiftInp:
     "igWlsInp MOD delta (lift h inp)  igWlsBinp MOD delta (lift hA binp)"
     using Op **** by simp
     have "wlsInp delta ?inpsw  wlsBinp delta ?binpsw"
     using Op by simp
     hence "?Left = igOp MOD delta (lift h ?inpsw) (lift hA ?binpsw)"
     using * unfolding ipresCons_def ipresOp_def by simp
     moreover
     have "lift h ?inpsw = igSwapInp MOD zs z1 z2 (lift h inp) 
           lift hA ?binpsw = igSwapBinp MOD zs z1 z2 (lift hA binp)"
     using Op * not_None_eq
     by (simp add:  igSwapCls_def igSwapIGOp_def wlsInp_iff wlsBinp_iff
     swapInp_def swapBinp_def igSwapInp_def igSwapBinp_def 
     lift_comp fun_eq_iff liftAll2_def lift_def sameDom_def split: option.splits)
     (metis not_None_eq old.prod.exhaust) 
     moreover
     have "igOp MOD delta (igSwapInp MOD zs z1 z2 (lift h inp))
                         (igSwapBinp MOD zs z1 z2 (lift hA binp)) =
           igSwap MOD zs z1 z2 (igOp MOD delta (lift h inp) (lift hA binp))"
     using wlsLiftInp ** unfolding igSwapCls_def igSwapIGOp_def by simp
     moreover
     have "igSwap MOD zs z1 z2 (igOp MOD delta (lift h inp) (lift hA binp)) = ?Right"
     using Op * unfolding ipresCons_def ipresOp_def by simp
     ultimately have "?Left = ?Right" by simp
     then show ?case by (simp add: Op)
   next
     case (Abs s xs x X)
     let ?Xsw = "swap zs z1 z2 X"  let ?xsw = "x @xs[z1  z2]_zs"
     have hX: "igWls MOD s (h X)" using Abs.IH *** unfolding ipresWlsAll_def ipresWls_def by simp
     let ?Left = "hA (Abs xs ?xsw ?Xsw)"
     let ?Right = "igSwapAbs MOD zs z1 z2 (hA (Abs xs x X))"
     have "wls s (swap zs z1 z2 X)" using Abs by simp
     hence "?Left = igAbs MOD xs ?xsw (h ?Xsw)"
     using Abs * unfolding ipresCons_def ipresAbs_def by blast
     also note Abs(3)
     also have "igAbs MOD xs ?xsw (igSwap MOD zs z1 z2 (h X)) =
                igSwapAbs MOD zs z1 z2 (igAbs MOD xs x (h X))"
     using Abs hX ** by (auto simp: igSwapCls_def igSwapIGAbs_def) 
     also have " = ?Right" using Abs * by (auto simp: ipresCons_def ipresAbs_def)
     finally have "?Left = ?Right" .
     then show ?case using Abs(2) by auto
   qed
  }
  thus ?thesis unfolding ipresSwapAll_defs by auto
qed 

lemma ipresCons_imp_ipresSubstAll_aux:
assumes *: "ipresCons h hA MOD" and **: "igSubstCls MOD"
and "igConsIPresIGWls MOD" and "igFreshCls MOD"
assumes P: "wlsPar P"
shows
"(wls s X 
  ( ys y Y. y  varsOfS P ys  Y  termsOfS P (asSort ys) 
             h (X #[Y / y]_ys) = igSubst MOD ys (h Y) y (h X)))

 (wlsAbs (us,s') A 
  ( ys y Y. y  varsOfS P ys  Y  termsOfS P (asSort ys) 
             hA (A $[Y / y]_ys) = igSubstAbs MOD ys (h Y) y (hA A)))"
proof-
  have ***: "ipresWlsAll h hA MOD"
  using assms ipresCons_imp_ipresWlsAll by auto
  hence ****:
  " delta inp. wlsInp delta inp  igWlsInp MOD delta (lift h inp)"
  " delta binp. wlsBinp delta binp  igWlsBinp MOD delta (lift hA binp)"
  unfolding ipresWlsAll_def using ipresWls_wlsInp ipresWls_wlsBinp by auto
  have *****: "ipresFreshAll h hA MOD"
  using assms ipresCons_imp_ipresFreshAll by auto
  (*  *)
  show ?thesis
  proof(induction rule: wls_induct_fresh[of P])
    case Par
    then show ?case using P by auto
  next
    case (Var xs x)
    then show ?case using assms
    by (simp add: ipresWlsAll_def ipresWls_def igSubstCls_def igSubstIGVar2_def 
       ipresCons_def ipresVar_def)  
    (metis "***" FixSyn.ipresWlsAll_defs(1) FixSyn.ipresWlsAll_defs(2) FixSyn_axioms 
      igSubstIGVar1_def wlsPar_def wls_subst_Var_simp1 wls_subst_Var_simp2)
  next
    case (Op delta inp binp)
    show ?case proof safe
      fix ys y Y
      assume yP: "y  varsOfS P ys" and YP: "Y  termsOfS P (asSort ys)"
      hence Y: "wls (asSort ys) Y" using P by auto
      hence hY: "igWls MOD (asSort ys) (h Y)"
      using *** unfolding ipresWlsAll_def ipresWls_def by simp
      have sinp: "wlsInp delta (substInp ys Y y inp) 
                wlsBinp delta (substBinp ys Y y binp)" using Y Op by simp
      have liftInp: "igWlsInp MOD delta (lift h inp) 
                     igWlsBinp MOD delta (lift hA binp)"
      using Op **** by simp
      let ?Left = "h ((Op delta inp binp) #[Y / y]_ys)"
      let ?Right = "igSubst MOD ys (h Y) y (h (Op delta inp binp))"
      have "?Left = igOp MOD delta (lift h (substInp ys Y y inp))
                                   (lift hA (substBinp ys Y y binp))"
      using sinp * unfolding ipresCons_def ipresOp_def  
      by (simp add: Op.IH(1) Op.IH(2) Y)
      moreover
      have "lift h (substInp ys Y y inp) = igSubstInp MOD ys (h Y) y (lift h inp) 
            lift hA (substBinp ys Y y binp) = igSubstBinp MOD ys (h Y) y (lift hA binp)"
      using Op YP yP by (simp add: substInp_def2 igSubstInp_def substBinp_def2 igSubstBinp_def lift_comp 
      lift_def liftAll2_def fun_eq_iff wlsInp_iff wlsBinp_iff sameDom_def split: option.splits) 
      (metis (no_types, hide_lams) not_Some_eq option.distinct(1) sinp wlsBinp.simps) 
      moreover
      have "igOp MOD delta (igSubstInp MOD ys (h Y) y (lift h inp))
                        (igSubstBinp MOD ys (h Y) y (lift hA binp)) =
            igSubst MOD ys (h Y) y (igOp MOD delta (lift h inp) (lift hA binp))"
      using hY liftInp ** unfolding igSubstCls_def igSubstIGOp_def by simp
      moreover have " = ?Right" using Op * unfolding ipresCons_def ipresOp_def by simp
      ultimately show "?Left = ?Right" by simp
    qed
    next
      case (Abs s xs x X)
      show ?case proof safe
      fix ys y Y 
      assume yP: "y  varsOfS P ys" and YP: "Y   termsOfS P (asSort ys)" 
      hence x_diff: "ys  xs  y  x"
      and Y: "wls (asSort ys) Y" and x_fresh: "fresh xs x Y" using P Abs by auto
      hence hY: "igWls MOD (asSort ys) (h Y)"
      using *** unfolding ipresWlsAll_def ipresWls_def by simp
      have hX: "igWls MOD s (h X)"
      using Abs *** unfolding ipresWlsAll_def ipresWls_def by simp
      let ?Xsb = "subst ys Y y X"
      have Xsb: "wls s ?Xsb" using Y Abs by simp
      have x_igFresh: "igFresh MOD xs x (h Y)"
      using Y x_fresh ***** unfolding ipresFreshAll_def ipresFresh_def by simp
      let ?Left = "hA (Abs xs x X $[Y / y]_ys)"
      let ?Right = "igSubstAbs MOD ys (h Y) y (hA (Abs xs x X))"
      have "?Left = hA (Abs xs x ?Xsb)" using Y Abs x_diff x_fresh by auto
      also have " = igAbs MOD xs x (h ?Xsb)"
      using Abs Xsb * unfolding ipresCons_def ipresAbs_def by fastforce
      also have " = igAbs MOD xs x (igSubst MOD ys (h Y) y (h X))"
      using yP YP Abs.IH by simp
      also have " = igSubstAbs MOD ys (h Y) y (igAbs MOD xs x (h X))"
      using Abs hY hX x_diff x_igFresh ** 
      by (auto simp: igSubstCls_def igSubstIGAbs_def) 
      also have " = ?Right" using Abs * by (auto simp: ipresCons_def ipresAbs_def) 
      finally show "?Left = ?Right" .
    qed 
  qed
qed 

lemma ipresCons_imp_ipresSubst:
assumes *: "ipresCons h hA MOD" and **: "igSubstCls MOD"
and "igConsIPresIGWls MOD" and "igFreshCls MOD"
shows "ipresSubst h MOD"
unfolding ipresSubst_def apply clarify 
subgoal for ys Y y s X 
using assms ipresCons_imp_ipresSubstAll_aux
  [of h hA MOD
      "ParS (λzs. if zs = ys then [y] else [])
            (λs'. if s' = asSort ys then [Y] else [])
            (λ_. [])
            []"]
unfolding wlsPar_def by auto .

lemma ipresCons_imp_ipresSubstAbs:
assumes *: "ipresCons h hA MOD" and **: "igSubstCls MOD"
and "igConsIPresIGWls MOD" and "igFreshCls MOD"
shows "ipresSubstAbs h hA MOD"
unfolding ipresSubstAbs_def apply clarify
subgoal for ys Y y us s A 
using assms ipresCons_imp_ipresSubstAll_aux
  [of h hA MOD
      "ParS (λzs. if zs = ys then [y] else [])
            (λs'. if s' = asSort ys then [Y] else [])
            (λ_. [])
            []"]
unfolding wlsPar_def by auto .

lemma ipresCons_imp_ipresSubstAll:
assumes *: "ipresCons h hA MOD" and **: "igSubstCls MOD"
and "igConsIPresIGWls MOD" and "igFreshCls MOD"
shows "ipresSubstAll h hA MOD"
unfolding ipresSubstAll_def using assms
ipresCons_imp_ipresSubst ipresCons_imp_ipresSubstAbs by auto

lemma iwlsFSw_termFSwImorph_iff:
"iwlsFSw MOD  termFSwImorph h hA MOD = ipresCons h hA MOD"
unfolding iwlsFSw_def termFSwImorph_def
using ipresCons_imp_ipresWlsAll
ipresCons_imp_ipresFreshAll ipresCons_imp_ipresSwapAll by auto

corollary iwlsFSwSTR_termFSwImorph_iff:
"iwlsFSwSTR MOD  termFSwImorph h hA MOD = ipresCons h hA MOD"
using iwlsFSwSTR_imp_iwlsFSw iwlsFSw_termFSwImorph_iff by fastforce

lemma iwlsFSb_termFSbImorph_iff:
"iwlsFSb MOD  termFSbImorph h hA MOD = ipresCons h hA MOD"
unfolding iwlsFSb_def termFSbImorph_def
using ipresCons_imp_ipresWlsAll
ipresCons_imp_ipresFreshAll ipresCons_imp_ipresSubstAll
unfolding igSubstCls_def by fastforce+

corollary iwlsFSbSwTR_termFSbImorph_iff:
"iwlsFSbSwTR MOD  termFSbImorph h hA MOD = ipresCons h hA MOD"
using iwlsFSbSwTR_imp_iwlsFSb iwlsFSb_termFSbImorph_iff by fastforce

lemma iwlsFSwSb_termFSwSbImorph_iff:
"iwlsFSwSb MOD  termFSwSbImorph h hA MOD = ipresCons h hA MOD"
unfolding termFSwSbImorph_def iwlsFSwSb_def
apply(simp add: iwlsFSw_termFSwImorph_iff)
unfolding iwlsFSw_def using ipresCons_imp_ipresSubstAll by auto

lemma iwlsFSbSw_termFSwSbImorph_iff:
"iwlsFSbSw MOD  termFSwSbImorph h hA MOD = ipresCons h hA MOD"
unfolding termFSwSbImorph_iff iwlsFSbSw_def
apply(simp add: iwlsFSb_termFSbImorph_iff)
unfolding iwlsFSb_def using ipresCons_imp_ipresSwapAll by auto

end (* context FixSyn *)

subsection‹The ``error" model of associated to a model›

text‹The error model will have the operators act like the original ones
on well-formed terms, except that will return ``ERR" (error) or ``True" (in the case of fresh)
whenever one of the inputs (variables, terms or abstractions) is ``ERR" or
is not well-formed.

The error model is more convenient than the original one, since
one can define more easily a map from the model of terms to the former. This map shall be defined
by the universal property of quotients, via a map from quasi-terms whose kernel
includes the alpha-equivalence relation. The latter property (of including
the alpha-equivalence would not be achievable with the original model as tariget, since
alpha is defined unsortedly and the model clauses hold sortedly.

We shall only need error models associated to fresh-swap and to fresh-subst models.›

subsubsection ‹Preliminaries›

(* I prefer defining a new type to using the option type, since
I already use options for inputs: *)

datatype 'a withERR = ERR | OK 'a

(* *************************************************** *)
context FixSyn   (* scope all throuighout the file *)
begin

definition OKI where
"OKI inp = lift OK inp"

definition check where
"check eX == THE X. eX = OK X"

definition checkI where
"checkI einp == lift check einp"

lemma check_ex_unique:
"eX  ERR  (EX! X. eX = OK X)"
by(cases eX, auto)

lemma check_OK[simp]:
"check (OK X) = X"
unfolding check_def using check_ex_unique theI' by auto

lemma OK_check[simp]:
"eX  ERR  OK (check eX) = eX"
unfolding check_def using check_ex_unique theI' by auto

lemma checkI_OKI[simp]:
"checkI (OKI inp) = inp"
unfolding OKI_def checkI_def lift_def apply(rule ext)
by(case_tac "inp i", auto)

lemma OKI_checkI[simp]:
assumes "liftAll (λ X. X  ERR) einp"
shows "OKI (checkI einp) = einp"
unfolding OKI_def checkI_def lift_def apply(rule ext)
using assms unfolding liftAll_def by (case_tac "einp i", auto)

lemma OKI_inj[simp]:
fixes inp inp' :: "('index,'gTerm)input"
shows "(OKI inp = OKI inp') = (inp = inp')"
apply(auto) unfolding OKI_def
using lift_preserves_inj[of OK]
unfolding inj_on_def by auto

lemmas OK_OKI_simps =
check_OK OK_check checkI_OKI OKI_checkI OKI_inj

subsubsection ‹Definitions and notations›

definition errMOD ::
"('index,'bindex,'varSort,'sort,'opSym,'var,'gTerm,'gAbs)model 
 ('index,'bindex,'varSort,'sort,'opSym,'var,'gTerm withERR,'gAbs withERR)model"
where
"errMOD MOD ==
 igWls = λ s eX. case eX of ERR  False | OK X  igWls MOD s X,
  igWlsAbs = λ (us,s) eA. case eA of ERR  False | OK A  igWlsAbs MOD (us,s) A,

  igVar = λ xs x. OK (igVar MOD xs x),
  igAbs = λxs x eX.
           if (eX  ERR  ( s. isInBar (xs,s)  igWls MOD s (check eX)))
             then OK (igAbs MOD xs x (check eX))
             else ERR,
  igOp = λdelta einp ebinp.
          if liftAll (λ X. X  ERR) einp  liftAll (λ A. A  ERR) ebinp
              igWlsInp MOD delta (checkI einp)  igWlsBinp MOD delta (checkI ebinp)
            then OK (igOp MOD delta (checkI einp) (checkI ebinp))
            else ERR,
  igFresh = λys y eX.
             if eX  ERR  ( s. igWls MOD s (check eX))
               then igFresh MOD ys y (check eX)
               else True,
  igFreshAbs = λys y eA.
                if eA  ERR  ( us s. igWlsAbs MOD (us,s) (check eA))
                  then igFreshAbs MOD ys y (check eA)
                  else True,
  igSwap = λzs z1 z2 eX.
            if eX  ERR  ( s. igWls MOD s (check eX))
              then OK (igSwap MOD zs z1 z2 (check eX))
              else ERR,
  igSwapAbs = λzs z1 z2 eA.
               if eA  ERR  ( us s. igWlsAbs MOD (us,s) (check eA))
                 then OK (igSwapAbs MOD zs z1 z2 (check eA))
                 else ERR,
  igSubst = λys eY y eX.
              if eY  ERR  igWls MOD (asSort ys) (check eY)
                  eX  ERR  ( s. igWls MOD s (check eX))
                then OK (igSubst MOD ys (check eY) y (check eX))
                else ERR,
  igSubstAbs = λys eY y eA.
                 if eY  ERR  igWls MOD (asSort ys) (check eY)
                     eA  ERR  ( us s. igWlsAbs MOD (us,s) (check eA))
                   then OK (igSubstAbs MOD ys (check eY) y (check eA))
                   else ERR
 "

abbreviation eWls where "eWls MOD == igWls (errMOD MOD)"
abbreviation eWlsAbs where "eWlsAbs MOD == igWlsAbs (errMOD MOD)"
abbreviation eWlsInp where "eWlsInp MOD == igWlsInp (errMOD MOD)"
abbreviation eWlsBinp where "eWlsBinp MOD == igWlsBinp (errMOD MOD)"
abbreviation eVar where "eVar MOD == igVar (errMOD MOD)"
abbreviation eAbs where "eAbs MOD == igAbs (errMOD MOD)"
abbreviation eOp where "eOp MOD == igOp (errMOD MOD)"
abbreviation eFresh where "eFresh MOD == igFresh (errMOD MOD)"
abbreviation eFreshAbs where "eFreshAbs MOD == igFreshAbs (errMOD MOD)"
abbreviation eFreshInp where "eFreshInp MOD == igFreshInp (errMOD MOD)"
abbreviation eFreshBinp where "eFreshBinp MOD == igFreshBinp (errMOD MOD)"
abbreviation eSwap where "eSwap MOD == igSwap (errMOD MOD)"
abbreviation eSwapAbs where "eSwapAbs MOD == igSwapAbs (errMOD MOD)"
abbreviation eSwapInp where "eSwapInp MOD == igSwapInp (errMOD MOD)"
abbreviation eSwapBinp where "eSwapBinp MOD == igSwapBinp (errMOD MOD)"
abbreviation eSubst where "eSubst MOD == igSubst (errMOD MOD)"
abbreviation eSubstAbs where "eSubstAbs MOD == igSubstAbs (errMOD MOD)"
abbreviation eSubstInp where "eSubstInp MOD == igSubstInp (errMOD MOD)"
abbreviation eSubstBinp where "eSubstBinp MOD == igSubstBinp (errMOD MOD)"

subsubsection ‹Simplification rules›

lemma eWls_simp1[simp]:
"eWls MOD s (OK X) = igWls MOD s X"
unfolding errMOD_def by simp

lemma eWls_simp2[simp]:
"eWls MOD s ERR = False"
unfolding errMOD_def by simp

lemma eWlsAbs_simp1[simp]:
"eWlsAbs MOD (us,s) (OK A) = igWlsAbs MOD (us,s) A"
unfolding errMOD_def by simp

lemma eWlsAbs_simp2[simp]:
"eWlsAbs MOD (us,s) ERR = False"
unfolding errMOD_def by simp

lemma eWlsInp_simp1[simp]:
"eWlsInp MOD delta (OKI inp) = igWlsInp MOD delta inp"
by (fastforce simp: OKI_def sameDom_def liftAll2_def lift_def igWlsInp_def 
  split: option.splits) 

lemma eWlsInp_simp2[simp]:
"¬ liftAll (λ eX. eX  ERR) einp  ¬ eWlsInp MOD delta einp"
by (force simp: sameDom_def liftAll_def liftAll2_def lift_def igWlsInp_def)  
 
corollary eWlsInp_simp3[simp]:
"¬ eWlsInp MOD delta (λi. Some ERR)"
by (auto simp: liftAll_def)
 
lemma eWlsBinp_simp1[simp]:
"eWlsBinp MOD delta (OKI binp) = igWlsBinp MOD delta binp"
by (fastforce simp: OKI_def sameDom_def liftAll2_def lift_def igWlsBinp_def 
  split: option.splits) 

lemma eWlsBinp_simp2[simp]:
"¬ liftAll (λ eA. eA  ERR) ebinp  ¬ eWlsBinp MOD delta ebinp"
by (force simp: sameDom_def liftAll_def liftAll2_def lift_def igWlsBinp_def)
 
corollary eWlsBinp_simp3[simp]:
"¬ eWlsBinp MOD delta (λi. Some ERR)"
by (auto simp: liftAll_def)
 
lemmas eWlsAll_simps =
eWls_simp1 eWls_simp2
eWlsAbs_simp1 eWlsAbs_simp2
eWlsInp_simp1 eWlsInp_simp2 eWlsInp_simp3
eWlsBinp_simp1 eWlsBinp_simp2 eWlsBinp_simp3

lemma eVar_simp[simp]:
"eVar MOD xs x = OK (igVar MOD xs x)"
unfolding errMOD_def by simp

lemma eAbs_simp1[simp]:
"isInBar (xs,s); igWls MOD s X  eAbs MOD xs x (OK X) = OK (igAbs MOD xs x X)"
unfolding errMOD_def by auto

lemma eAbs_simp2[simp]:
" s. ¬ (isInBar (xs,s)  igWls MOD s X)  eAbs MOD xs x (OK X) = ERR"
unfolding errMOD_def by auto

lemma eAbs_simp3[simp]:
"eAbs MOD xs x ERR = ERR"
unfolding errMOD_def by auto

lemma eOp_simp1[simp]:
assumes "igWlsInp MOD delta inp" and "igWlsBinp MOD delta binp"
shows "eOp MOD delta (OKI inp) (OKI binp) = OK (igOp MOD delta inp binp)"
unfolding errMOD_def apply simp
unfolding liftAll_def OKI_def lift_def  
using assms by (auto split: option.splits)

lemma eOp_simp2[simp]:
assumes "¬ igWlsInp MOD delta inp"
shows "eOp MOD delta (OKI inp) ebinp = ERR"
using assms unfolding errMOD_def by auto

lemma eOp_simp3[simp]:
assumes "¬ igWlsBinp MOD delta binp"
shows "eOp MOD delta einp (OKI binp) = ERR"
using assms unfolding errMOD_def by auto

lemma eOp_simp4[simp]:
assumes "¬ liftAll (λ eX. eX  ERR) einp"
shows "eOp MOD delta einp ebinp = ERR"
using assms unfolding errMOD_def by auto

corollary eOp_simp5[simp]:
"eOp MOD delta (λi. Some ERR) ebinp = ERR"
by (auto simp: liftAll_def)
 
lemma eOp_simp6[simp]:
assumes "¬ liftAll (λ eA. eA  ERR) ebinp"
shows "eOp MOD delta einp ebinp = ERR"
using assms unfolding errMOD_def by auto

corollary eOp_simp7[simp]:
"eOp MOD delta einp (λi. Some ERR) = ERR"
by (auto simp: liftAll_def)
 
lemmas eCons_simps =
eVar_simp
eAbs_simp1 eAbs_simp2 eAbs_simp3
eOp_simp1 eOp_simp2 eOp_simp3 eOp_simp4 eOp_simp5 eOp_simp6 eOp_simp7

lemma eFresh_simp1[simp]:
"igWls MOD s X  eFresh MOD ys y (OK X) = igFresh MOD ys y X"
unfolding errMOD_def by auto

lemma eFresh_simp2[simp]:
" s. ¬ igWls MOD s X  eFresh MOD ys y (OK X)"
unfolding errMOD_def by auto

lemma eFresh_simp3[simp]:
"eFresh MOD ys y ERR"
unfolding errMOD_def by auto

lemma eFreshAbs_simp1[simp]:
"igWlsAbs MOD (us,s) A  eFreshAbs MOD ys y (OK A) = igFreshAbs MOD ys y A"
unfolding errMOD_def by auto

lemma eFreshAbs_simp2[simp]:
" us s. ¬ igWlsAbs MOD (us,s) A  eFreshAbs MOD ys y (OK A)"
unfolding errMOD_def by auto

lemma eFreshAbs_simp3[simp]:
"eFreshAbs MOD ys y ERR"
unfolding errMOD_def by auto

lemma eFreshInp_simp[simp]:
"igWlsInp MOD delta inp
  eFreshInp MOD ys y (OKI inp) = igFreshInp MOD ys y inp"
by (force simp: igFreshInp_def OKI_def liftAll_lift_comp igWlsInp_defs intro!: liftAll_cong)
 
lemma eFreshBinp_simp[simp]:
"igWlsBinp MOD delta binp
  eFreshBinp MOD ys y (OKI binp) = igFreshBinp MOD ys y binp"
by (force simp: igFreshBinp_def OKI_def liftAll_lift_comp igWlsBinp_defs intro!: liftAll_cong)
 
lemmas eFreshAll_simps =
eFresh_simp1 eFresh_simp2 eFresh_simp3
eFreshAbs_simp1 eFreshAbs_simp2 eFreshAbs_simp3
eFreshInp_simp
eFreshBinp_simp

lemma eSwap_simp1[simp]:
"igWls MOD s X
  eSwap MOD zs z1 z2 (OK X) = OK (igSwap MOD zs z1 z2 X)"
unfolding errMOD_def by auto

lemma eSwap_simp2[simp]:
" s. ¬ igWls MOD s X  eSwap MOD zs z1 z2 (OK X) = ERR"
unfolding errMOD_def by auto

lemma eSwap_simp3[simp]:
"eSwap MOD zs z1 z2 ERR = ERR"
unfolding errMOD_def by auto

lemma eSwapAbs_simp1[simp]:
"igWlsAbs MOD (us,s) A
  eSwapAbs MOD zs z1 z2 (OK A) = OK (igSwapAbs MOD zs z1 z2 A)"
unfolding errMOD_def by auto

lemma eSwapAbs_simp2[simp]:
" us s. ¬ igWlsAbs MOD (us,s) A  eSwapAbs MOD zs z1 z2 (OK A) = ERR"
unfolding errMOD_def by auto

lemma eSwapAbs_simp3[simp]:
"eSwapAbs MOD zs z1 z2 ERR = ERR"
unfolding errMOD_def by auto

lemma eSwapInp_simp1[simp]:
"igWlsInp MOD delta inp
  eSwapInp MOD zs z1 z2 (OKI inp) = OKI (igSwapInp MOD zs z1 z2 inp)"
by (force simp: igSwapInp_def OKI_def lift_comp igWlsInp_defs intro!: lift_cong)

lemma eSwapInp_simp2[simp]:
assumes "¬ liftAll (λ eX. eX  ERR) einp"
shows "¬ liftAll (λ eX. eX  ERR) (eSwapInp MOD zs z1 z2 einp)"
using assms unfolding liftAll_def igSwapInp_def lift_def by (auto split: option.splits)

lemma eSwapBinp_simp1[simp]:
"igWlsBinp MOD delta binp
  eSwapBinp MOD zs z1 z2 (OKI binp) = OKI (igSwapBinp MOD zs z1 z2 binp)"
by (force simp: igSwapBinp_def OKI_def lift_comp igWlsBinp_defs intro!: lift_cong)

lemma eSwapBinp_simp2[simp]:
assumes "¬ liftAll (λ eA. eA  ERR) ebinp"
shows "¬ liftAll (λ eA. eA  ERR) (eSwapBinp MOD zs z1 z2 ebinp)"
using assms unfolding liftAll_def igSwapBinp_def lift_def by (auto split: option.splits)
 
lemmas eSwapAll_simps =
eSwap_simp1 eSwap_simp2 eSwap_simp3
eSwapAbs_simp1 eSwapAbs_simp2 eSwapAbs_simp3
eSwapInp_simp1 eSwapInp_simp2
eSwapBinp_simp1 eSwapBinp_simp2

lemma eSubst_simp1[simp]:
"igWls MOD (asSort ys) Y; igWls MOD s X
  eSubst MOD ys (OK Y) y (OK X) = OK (igSubst MOD ys Y y X)"
unfolding errMOD_def by auto

lemma eSubst_simp2[simp]:
"¬ igWls MOD (asSort ys) Y  eSubst MOD ys (OK Y) y eX = ERR"
unfolding errMOD_def by auto

lemma eSubst_simp3[simp]:
" s. ¬ igWls MOD s X  eSubst MOD ys eY y (OK X) = ERR"
unfolding errMOD_def by auto

lemma eSubst_simp4[simp]:
"eSubst MOD ys eY y ERR = ERR"
unfolding errMOD_def by auto

lemma eSubst_simp5[simp]:
"eSubst MOD ys ERR y eX = ERR"
unfolding errMOD_def by auto

lemma eSubstAbs_simp1[simp]:
"igWls MOD (asSort ys) Y; igWlsAbs MOD (us,s) A
  eSubstAbs MOD ys (OK Y) y (OK A) = OK (igSubstAbs MOD ys Y y A)"
unfolding errMOD_def by auto

lemma eSubstAbs_simp2[simp]:
"¬ igWls MOD (asSort ys) Y  eSubstAbs MOD ys (OK Y) y eA = ERR"
unfolding errMOD_def by auto

lemma eSubstAbs_simp3[simp]:
" us s. ¬ igWlsAbs MOD (us,s) A  eSubstAbs MOD ys eY y (OK A) = ERR"
unfolding errMOD_def by auto

lemma eSubstAbs_simp4[simp]:
"eSubstAbs MOD ys eY y ERR = ERR"
unfolding errMOD_def by auto

lemma eSubstAbs_simp5[simp]:
"eSubstAbs MOD ys ERR y eA = ERR"
unfolding errMOD_def by auto

lemma eSubstInp_simp1[simp]:
"igWls MOD (asSort ys) Y; igWlsInp MOD delta inp
  eSubstInp MOD ys (OK Y) y (OKI inp) = OKI (igSubstInp MOD ys Y y inp)"
by (force simp: igSubstInp_def OKI_def lift_comp igWlsInp_defs intro!: lift_cong)

lemma eSubstInp_simp2[simp]:
assumes "¬ liftAll (λeX. eX  ERR) einp"
shows "¬ liftAll (λeX. eX  ERR) (eSubstInp MOD ys eY y einp)"
using assms unfolding lift_def igSubstInp_def liftAll_def by (auto split: option.splits)
 
lemma eSubstInp_simp3[simp]:
assumes *: "¬ igWls MOD (asSort ys) Y" and **: "¬ einp = (λ i. None)"
shows "¬ liftAll (λeX. eX  ERR) (eSubstInp MOD ys (OK Y) y einp)"
using assms by (auto simp: igSubstInp_def liftAll_lift_comp lift_def liftAll_def 
split: option.splits) 

lemma eSubstInp_simp4[simp]:
assumes "¬ einp = (λ i. None)"
shows "¬ liftAll (λeX. eX  ERR) (eSubstInp MOD ys ERR y einp)"
using assms by (auto simp: igSubstInp_def liftAll_lift_comp lift_def liftAll_def 
split: option.splits)  

lemma eSubstBinp_simp1[simp]:
"igWls MOD (asSort ys) Y; igWlsBinp MOD delta binp
  eSubstBinp MOD ys (OK Y) y (OKI binp) = OKI (igSubstBinp MOD ys Y y binp)"
by (force simp: igSubstBinp_def OKI_def lift_comp igWlsBinp_defs intro!: lift_cong)
 
lemma eSubstBinp_simp2[simp]:
assumes "¬ liftAll (λeA. eA  ERR) ebinp"
shows "¬ liftAll (λeA. eA  ERR) (eSubstBinp MOD ys eY y ebinp)"
using assms by (auto simp: igSubstBinp_def liftAll_lift_comp lift_def liftAll_def 
split: option.splits)  
 
lemma eSubstBinp_simp3[simp]:
assumes *: "¬ igWls MOD (asSort ys) Y" and **: "¬ ebinp = (λ i. None)"
shows "¬ liftAll (λeA. eA  ERR) (eSubstBinp MOD ys (OK Y) y ebinp)"
using assms by (auto simp: igSubstBinp_def liftAll_lift_comp lift_def liftAll_def 
split: option.splits)  

lemma eSubstBinp_simp4[simp]:
assumes "¬ ebinp = (λ i. None)"
shows "¬ liftAll (λeA. eA  ERR) (eSubstBinp MOD ys ERR y ebinp)"
using assms by (auto simp: igSubstBinp_def liftAll_lift_comp lift_def liftAll_def 
split: option.splits) 

lemmas eSubstAll_simps =
eSubst_simp1 eSubst_simp2 eSubst_simp3 eSubst_simp4 eSubst_simp5
eSubstAbs_simp1 eSubstAbs_simp2 eSubstAbs_simp3 eSubstAbs_simp4 eSubstAbs_simp5
eSubstInp_simp1 eSubstInp_simp2 eSubstInp_simp3 eSubstInp_simp4
eSubstBinp_simp1 eSubstBinp_simp2 eSubstBinp_simp3 eSubstBinp_simp4

lemmas error_model_simps =
OK_OKI_simps
eWlsAll_simps
eCons_simps
eFreshAll_simps
eSwapAll_simps
eSubstAll_simps

subsubsection ‹Nchotomies›

lemma eWls_nchotomy:
"( X. eX = OK X  igWls MOD s X)  ¬ eWls MOD s eX"
unfolding errMOD_def by(cases eX) auto

lemma eWlsAbs_nchotomy:
"( A. eA = OK A  igWlsAbs MOD (us,s) A)  ¬ eWlsAbs MOD (us,s) eA"
unfolding errMOD_def by(cases eA) auto

lemma eAbs_nchotomy:
"(( s X. eX = OK X  isInBar (xs,s)  igWls MOD s X))  (eAbs MOD xs x eX = ERR)"
unfolding errMOD_def apply simp using OK_check by fastforce

lemma eOp_nchotomy:
"( inp binp. einp = OKI inp  igWlsInp MOD delta inp 
              ebinp = OKI binp  igWlsBinp MOD delta binp)
  
 (eOp MOD delta einp ebinp = ERR)"
unfolding errMOD_def apply simp using OKI_checkI by force

lemma eFresh_nchotomy:
"( s X. eX = OK X  igWls MOD s X)  eFresh MOD ys y eX"
unfolding errMOD_def apply simp using OK_check by fastforce

lemma eFreshAbs_nchotomy:
"( us s A. eA = OK A  igWlsAbs MOD (us,s) A)
  eFreshAbs MOD ys y eA"
unfolding errMOD_def apply simp using OK_check by fastforce

lemma eSwap_nchotomy:
"( s X. eX = OK X  igWls MOD s X) 
 (eSwap MOD zs z1 z2 eX = ERR)"
unfolding errMOD_def apply simp using OK_check by fastforce

lemma eSwapAbs_nchotomy:
"( us s A. eA = OK A  igWlsAbs MOD (us,s) A) 
 (eSwapAbs MOD zs z1 z2 eA = ERR)"
unfolding errMOD_def apply simp using OK_check by fastforce

lemma eSubst_nchotomy:
"( Y. eY = OK Y 
  igWls MOD (asSort ys) Y)  ( s X. eX = OK X  igWls MOD s X)
 
 (eSubst MOD ys eY y eX = ERR)"
unfolding errMOD_def apply simp using OK_check by fastforce 

lemma eSubstAbs_nchotomy:
"( Y. eY = OK Y  igWls MOD (asSort ys) Y) 
 ( us s A. eA = OK A  igWlsAbs MOD (us,s) A)
 
 (eSubstAbs MOD ys eY y eA = ERR)"
unfolding errMOD_def apply simp using OK_check by fastforce


subsubsection ‹Inversion rules›

lemma eWls_invert:
assumes "eWls MOD s eX"
shows " X. eX = OK X  igWls MOD s X"
using assms eWls_nchotomy by blast

lemma eWlsAbs_invert:
assumes "eWlsAbs MOD (us,s) eA"
shows " A. eA = OK A  igWlsAbs MOD (us,s) A"
using assms eWlsAbs_nchotomy by blast

lemma eWlsInp_invert:
assumes "eWlsInp MOD delta einp"
shows " inp. igWlsInp MOD delta inp  einp = OKI inp"
proof
  let ?inp = "checkI einp"
  have "wlsOpS delta" using assms unfolding igWlsInp_def by simp
  moreover have "sameDom (arOf delta) ?inp"
  using assms unfolding igWlsInp_def  checkI_def by simp
  moreover have "liftAll2 (igWls MOD) (arOf delta) ?inp"
  using assms eWls_invert
  by (fastforce simp: igWlsInp_def checkI_def liftAll2_def lift_def sameDom_def 
  split: option.splits) 
  ultimately have "igWlsInp MOD delta ?inp" unfolding igWlsInp_def by simp
  moreover
  {have "liftAll (λeX. eX  ERR) einp"
   using assms using eWlsInp_simp2 by blast
   hence "einp = OKI ?inp" by simp
  }
  ultimately show "igWlsInp MOD delta ?inp  einp = OKI ?inp" by simp
qed

lemma eWlsBinp_invert:
assumes "eWlsBinp MOD delta ebinp"
shows " binp. igWlsBinp MOD delta binp  ebinp = OKI binp"
proof
  let ?binp = "checkI ebinp"
  have "wlsOpS delta" using assms unfolding igWlsBinp_def by simp
  moreover have "sameDom (barOf delta) ?binp"
  using assms unfolding igWlsBinp_def  checkI_def by simp
  moreover have "liftAll2 (igWlsAbs MOD) (barOf delta) ?binp"
  using assms eWlsAbs_invert
  by (fastforce simp: igWlsBinp_def checkI_def liftAll2_def lift_def sameDom_def 
  split: option.splits)
  ultimately have "igWlsBinp MOD delta ?binp" unfolding igWlsBinp_def by simp
  moreover
  {have "liftAll (λeA. eA  ERR) ebinp"
   using assms using eWlsBinp_simp2 by blast
   hence "ebinp = OKI ?binp" by simp
  }
  ultimately show "igWlsBinp MOD delta ?binp  ebinp = OKI ?binp" by simp
qed

lemma eAbs_invert:
assumes "eAbs MOD xs x eX = OK A"
shows " s X. eX = OK X  isInBar (xs,s)  A = igAbs MOD xs x X  igWls MOD s X"
proof-
  have 1: "eAbs MOD xs x eX  ERR" using assms by auto
  then obtain s X where *: "eX = OK X"
  and **: "isInBar (xs,s)" and ***: "igWls MOD s X"
  using eAbs_nchotomy[of eX] by fastforce
  hence "eAbs MOD xs x eX = OK (igAbs MOD xs x X)" by simp
  thus ?thesis using assms * ** *** by auto
qed

lemma eOp_invert:
assumes "eOp MOD delta einp ebinp = OK X"
shows
" inp binp. einp = OKI inp  ebinp = OKI binp 
             X = igOp MOD delta inp binp 
             igWlsInp MOD delta inp  igWlsBinp MOD delta binp"
proof-
  have "eOp MOD delta einp ebinp  ERR" using assms by auto
  then obtain inp binp where *: "einp = OKI inp"   "ebinp = OKI binp"
  "igWlsInp MOD delta inp"   "igWlsBinp MOD delta binp"
  using eOp_nchotomy by blast
  hence "eOp MOD delta einp ebinp = OK (igOp MOD delta inp binp)" by simp
  thus ?thesis using assms * by auto
qed

lemma eFresh_invert:
assumes "¬ eFresh MOD ys y eX"
shows " s X. eX = OK X  ¬ igFresh MOD ys y X  igWls MOD s X"
proof-
  obtain s X where *: "eX = OK X" and **: "igWls MOD s X"
  using assms eFresh_nchotomy[of eX] by fastforce
  hence "eFresh MOD ys y eX = igFresh MOD ys y X" by simp
  thus ?thesis using assms * ** by auto
qed

lemma eFreshAbs_invert:
assumes "¬ eFreshAbs MOD ys y eA"
shows " us s A. eA = OK A  ¬ igFreshAbs MOD ys y A  igWlsAbs MOD (us,s) A"
proof-
  obtain us s A where *: "eA = OK A" and **: "igWlsAbs MOD (us,s) A"
  using assms eFreshAbs_nchotomy[of eA] by fastforce
  hence "eFreshAbs MOD ys y eA = igFreshAbs MOD ys y A" by simp
  thus ?thesis using assms * ** by auto
qed

lemma eSwap_invert:
assumes "eSwap MOD zs z1 z2 eX = OK Y"
shows " s X. eX = OK X  Y = igSwap MOD zs z1 z2 X  igWls MOD s X"
proof-
  have 1: "eSwap MOD zs z1 z2 eX  ERR" using assms by auto
  then obtain s X where *: "eX = OK X" and **: "igWls MOD s X"
  using eSwap_nchotomy[of eX] by fastforce
  hence "eSwap MOD zs z1 z2 eX = OK (igSwap MOD zs z1 z2 X)" by simp
  thus ?thesis using assms * ** by auto
qed

lemma eSwapAbs_invert:
assumes "eSwapAbs MOD zs z1 z2 eA = OK B"
shows " us s A. eA = OK A  B = igSwapAbs MOD zs z1 z2 A  igWlsAbs MOD (us,s) A"
proof-
  have 1: "eSwapAbs MOD zs z1 z2 eA  ERR" using assms by auto
  then obtain us s A where *: "eA = OK A" and **: "igWlsAbs MOD (us,s) A"
  using eSwapAbs_nchotomy[of eA] by fastforce
  hence "eSwapAbs MOD zs z1 z2 eA = OK (igSwapAbs MOD zs z1 z2 A)" by simp
  thus ?thesis using assms * ** by auto
qed

lemma eSubst_invert:
assumes "eSubst MOD ys eY y eX = OK Z"
shows
" s X Y. eY = OK Y  eX = OK X  igWls MOD s X  igWls MOD (asSort ys) Y 
          Z = igSubst MOD ys Y y X"
proof-
  have 1: "eSubst MOD ys eY y eX  ERR" using assms by auto
  then obtain s X Y where *: "eX = OK X"   "eY = OK Y"
  "igWls MOD s X"  "igWls MOD (asSort ys) Y"
  using eSubst_nchotomy[of eY _ _ eX] by fastforce
  hence "eSubst MOD ys eY y eX = OK (igSubst MOD ys Y y X)" by simp
  thus ?thesis using assms * by auto
qed

lemma eSubstAbs_invert:
assumes "eSubstAbs MOD ys eY y eA = OK Z"
shows
" us s A Y. eY = OK Y  eA = OK A  igWlsAbs MOD (us,s) A  igWls MOD (asSort ys) Y 
             Z = igSubstAbs MOD ys Y y A"
proof-
  have 1: "eSubstAbs MOD ys eY y eA  ERR" using assms by auto
  then obtain us s A Y where *: "eA = OK A"   "eY = OK Y"
  "igWlsAbs MOD (us,s) A"  "igWls MOD (asSort ys) Y"
  using eSubstAbs_nchotomy[of eY _ _ eA] by fastforce
  hence "eSubstAbs MOD ys eY y eA = OK (igSubstAbs MOD ys Y y A)" by simp
  thus ?thesis using assms * by auto
qed

subsubsection ‹The error model is strongly well-sorted
as a fresh-swap-subst and as a fresh-subst-swap model›

text‹That is, provided the original model is a well-sorted fresh-swap model.›

text‹The domains are disjoint:›

lemma errMOD_igWlsDisj:
assumes "igWlsDisj MOD"
shows "igWlsDisj (errMOD MOD)"
using assms unfolding errMOD_def igWlsDisj_def  
apply clarify subgoal for _ _ X by(cases X) auto . 

lemma errMOD_igWlsAbsDisj:
assumes "igWlsAbsDisj MOD"
shows "igWlsAbsDisj (errMOD MOD)"
using assms unfolding errMOD_def igWlsAbsDisj_def
apply clarify subgoal for _ _ _ _ A by(cases A) fastforce+ . 

lemma errMOD_igWlsAllDisj:
assumes "igWlsAllDisj MOD"
shows "igWlsAllDisj (errMOD MOD)"
using assms unfolding igWlsAllDisj_def
using errMOD_igWlsDisj errMOD_igWlsAbsDisj by auto

text‹Only ``bound arity" abstraction domains are inhabited:›

lemma errMOD_igWlsAbsIsInBar:
assumes "igWlsAbsIsInBar MOD"
shows "igWlsAbsIsInBar (errMOD MOD)"
using assms eWlsAbs_invert unfolding igWlsAbsIsInBar_def by blast
 

text‹The operators preserve the domains strongly:›

lemma errMOD_igVarIPresIGWlsSTR:
assumes "igVarIPresIGWls MOD"
shows "igVarIPresIGWls (errMOD MOD)"
using assms unfolding errMOD_def igVarIPresIGWls_def by simp

lemma errMOD_igAbsIPresIGWlsSTR:
assumes *: "igAbsIPresIGWls MOD" and **: "igWlsAbsDisj MOD"
and ***: "igWlsAbsIsInBar MOD"
shows "igAbsIPresIGWlsSTR (errMOD MOD)"
using assms by (fastforce simp: errMOD_def igAbsIPresIGWls_def igAbsIPresIGWlsSTR_def 
igWlsAbsIsInBar_def igWlsAbsDisj_def split: withERR.splits) 
  
lemma errMOD_igOpIPresIGWlsSTR:
fixes MOD :: "('index,'bindex,'varSort,'sort,'opSym,'var,'gTerm,'gAbs)model"
assumes "igOpIPresIGWls MOD"
shows "igOpIPresIGWlsSTR (errMOD MOD)"
by (simp add: igOpIPresIGWlsSTR_def igOpIPresIGWls_def) 
  (smt assms eOp_nchotomy eOp_simp1 eWlsBinp_invert 
eWlsBinp_simp1 eWlsInp_invert eWlsInp_simp1 eWls_simp1 eWls_simp2 igOpIPresIGWls_def) 

lemma errMOD_igConsIPresIGWlsSTR:
assumes "igConsIPresIGWls MOD" and "igWlsAllDisj MOD"
and "igWlsAbsIsInBar MOD"
shows "igConsIPresIGWlsSTR (errMOD MOD)"
using assms unfolding igConsIPresIGWls_def igConsIPresIGWlsSTR_def igWlsAllDisj_def
using
errMOD_igVarIPresIGWlsSTR[of MOD]
errMOD_igAbsIPresIGWlsSTR[of MOD]
errMOD_igOpIPresIGWlsSTR[of MOD]
by auto

lemma errMOD_igSwapIPresIGWlsSTR:
assumes "igSwapIPresIGWls MOD" and "igWlsDisj MOD"
shows "igSwapIPresIGWlsSTR (errMOD MOD)"
using ‹igSwapIPresIGWls MOD 
using assms by (fastforce simp: errMOD_def igSwapIPresIGWls_def igSwapIPresIGWlsSTR_def 
igWlsDisj_def split: withERR.splits) 

lemma errMOD_igSwapAbsIPresIGWlsAbsSTR:
assumes *: "igSwapAbsIPresIGWlsAbs MOD" and **: "igWlsAbsDisj MOD"
and ***: "igWlsAbsIsInBar MOD"
shows "igSwapAbsIPresIGWlsAbsSTR (errMOD MOD)"
using assms by (simp add: errMOD_def igSwapAbsIPresIGWlsAbs_def igSwapAbsIPresIGWlsAbsSTR_def 
igWlsAbsIsInBar_def igWlsAbsDisj_def split: withERR.splits) blast

lemma errMOD_igSwapAllIPresIGWlsAllSTR:
assumes "igSwapAllIPresIGWlsAll MOD" and "igWlsAllDisj MOD"
and "igWlsAbsIsInBar MOD"
shows "igSwapAllIPresIGWlsAllSTR (errMOD MOD)"
using assms
unfolding igSwapAllIPresIGWlsAll_def igSwapAllIPresIGWlsAllSTR_def igWlsAllDisj_def
using errMOD_igSwapIPresIGWlsSTR[of MOD] errMOD_igSwapIPresIGWlsSTR[of MOD]
errMOD_igSwapAbsIPresIGWlsAbsSTR[of MOD]
by auto

lemma errMOD_igSubstIPresIGWlsSTR:
assumes "igSubstIPresIGWls MOD" and "igWlsDisj MOD"
shows "igSubstIPresIGWlsSTR (errMOD MOD)"
using ‹igSubstIPresIGWls MOD
using assms by (fastforce simp: errMOD_def igSubstIPresIGWls_def igSubstIPresIGWlsSTR_def 
igWlsDisj_def split: withERR.splits)
 
lemma errMOD_igSubstAbsIPresIGWlsAbsSTR:
assumes *: "igSubstAbsIPresIGWlsAbs MOD" and **: "igWlsAbsDisj MOD"
and ***: "igWlsAbsIsInBar MOD"
shows "igSubstAbsIPresIGWlsAbsSTR (errMOD MOD)"
using assms by (simp add: errMOD_def igSubstAbsIPresIGWlsAbs_def igSubstAbsIPresIGWlsAbsSTR_def 
igWlsAbsIsInBar_def igWlsAbsDisj_def split: withERR.splits) blast

lemma errMOD_igSubstAllIPresIGWlsAllSTR:
assumes "igSubstAllIPresIGWlsAll MOD" and "igWlsAllDisj MOD"
and "igWlsAbsIsInBar MOD"
shows "igSubstAllIPresIGWlsAllSTR (errMOD MOD)"
using assms
unfolding igSubstAllIPresIGWlsAll_def igSubstAllIPresIGWlsAllSTR_def igWlsAllDisj_def
using errMOD_igSubstIPresIGWlsSTR[of MOD] errMOD_igSubstIPresIGWlsSTR[of MOD]
errMOD_igSubstAbsIPresIGWlsAbsSTR[of MOD]
by auto

text‹The strong ``fresh" clauses are satisfied:›

lemma errMOD_igFreshIGVarSTR:
assumes "igVarIPresIGWls MOD" and "igFreshIGVar MOD"
shows "igFreshIGVar (errMOD MOD)"
using assms eFresh_simp1 
by(fastforce simp: igVarIPresIGWls_def igFreshIGVar_def)

lemma errMOD_igFreshIGAbs1STR:
assumes *: "igAbsIPresIGWls MOD" and **: "igFreshIGAbs1 MOD"
shows "igFreshIGAbs1STR (errMOD MOD)"
unfolding igFreshIGAbs1STR_def proof(clarify)
  fix ys y eX
  show "eFreshAbs MOD ys y (eAbs MOD ys y eX)"
  proof(cases "eX  ERR")
    define X where "X  check eX"
    case True 
    hence eX: "eX = OK X" unfolding X_def using OK_check by auto
    show ?thesis using assms eFreshAbs_simp1 unfolding eX 
    by (cases " s. isInBar (ys,s)  igWls MOD s X")
    (fastforce simp: igAbsIPresIGWls_def igFreshIGAbs1_def)+
  qed auto
qed

lemma errMOD_igFreshIGAbs2STR:
assumes "igAbsIPresIGWls MOD" and "igFreshIGAbs2 MOD"
shows "igFreshIGAbs2STR (errMOD MOD)"
unfolding igFreshIGAbs2STR_def proof(clarify)
  fix ys y xs x eX
  assume *: "eFresh MOD ys y eX"
  define X where "X  check eX"
  show "eFreshAbs MOD ys y (eAbs MOD xs x eX)"
  proof(cases "eX  ERR") 
    case True
    hence eX: "eX = OK X" unfolding X_def using OK_check by auto
    show ?thesis unfolding eX
    using assms * eFreshAbs_invert eX  
    by (cases " s. isInBar (xs,s)  igWls MOD s X")
    (fastforce simp: igAbsIPresIGWls_def igFreshIGAbs2_def)+  
  qed auto
qed

(* HERE *)

lemma errMOD_igFreshIGOpSTR:
fixes MOD :: "('index,'bindex,'varSort,'sort,'opSym,'var,'gTerm,'gAbs)model"
assumes "igOpIPresIGWls MOD" and "igFreshIGOp MOD"
shows "igFreshIGOpSTR (errMOD MOD)"
unfolding igFreshIGOpSTR_def apply clarify
subgoal for ys y delta einp ebinp
apply(cases "liftAll (λeX. eX  ERR) einp 
               liftAll (λeA. eA  ERR) ebinp")
using assms by (simp_all add: igOpIPresIGWls_def  igFreshIGOp_def)
(metis eFreshBinp_simp eFreshInp_simp eFresh_invert eOp_invert)+ .

lemma errMOD_igFreshClsSTR:
assumes "igConsIPresIGWls MOD" and "igFreshCls MOD"
shows "igFreshClsSTR (errMOD MOD)"
using assms unfolding igConsIPresIGWls_def igFreshCls_def igFreshClsSTR_def
using
errMOD_igFreshIGVarSTR
errMOD_igFreshIGAbs1STR errMOD_igFreshIGAbs2STR
errMOD_igFreshIGOpSTR
by auto

text‹The strong ``swap" clauses are satisfied:›

lemma errMOD_igSwapIGVarSTR:
fixes MOD :: "('index,'bindex,'varSort,'sort,'opSym,'var,'gTerm,'gAbs)model"
assumes "igVarIPresIGWls MOD" and "igSwapIGVar MOD"
shows "igSwapIGVar (errMOD MOD)"
using assms by (simp add: igVarIPresIGWls_def igSwapIGVar_def) (metis eSwap_simp1)

lemma errMOD_igSwapIGAbsSTR:
assumes *: "igAbsIPresIGWls MOD" and **: "igWlsDisj MOD"
and ***: "igSwapIPresIGWls MOD" and ****: "igSwapIGAbs MOD"
shows "igSwapIGAbsSTR (errMOD MOD)"
unfolding igSwapIGAbsSTR_def apply(clarify)
subgoal for zs z1 z2 xs x eX
apply (cases eX)
 subgoal by auto
 subgoal for X
 apply(cases " s. isInBar (xs,s)  igWls MOD s X") 
  subgoal using assms 
  using assms OK_check 
  by (simp_all add: igAbsIPresIGWls_def igSwapIPresIGWls_def igSwapIGAbs_def igWlsDisj_def)  
     (smt eAbs_simp1 eSwapAbs_simp1 eSwap_simp1 withERR.inject)
  subgoal using assms 
  by(simp_all add: igAbsIPresIGWls_def igSwapIPresIGWls_def igSwapIGAbs_def igWlsDisj_def)  
    (metis check_OK eAbs_nchotomy eSwap_invert) . . .
 
lemma errMOD_igSwapIGOpSTR:
assumes "igWlsAbsIsInBar MOD" and "igOpIPresIGWls MOD"
and "igSwapIPresIGWls MOD" and "igSwapAbsIPresIGWlsAbs MOD"
and "igWlsDisj MOD" and "igWlsAbsDisj MOD"
and "igSwapIGOp MOD"
shows "igSwapIGOpSTR (errMOD MOD)"
unfolding igSwapIGOpSTR_def proof(clarify)
  have 0: "igSwapInpIPresIGWlsInp MOD  igSwapBinpIPresIGWlsBinp MOD"
  using ‹igSwapIPresIGWls MOD  ‹igSwapAbsIPresIGWlsAbs MOD
  imp_igSwapInpIPresIGWlsInp imp_igSwapBinpIPresIGWlsBinp by auto
  have "igSwapIPresIGWlsSTR (errMOD MOD) 
        igSwapAbsIPresIGWlsAbsSTR (errMOD MOD)"
  using assms errMOD_igSwapIPresIGWlsSTR
        errMOD_igSwapAbsIPresIGWlsAbsSTR by auto
  hence 1: "igSwapInpIPresIGWlsInpSTR (errMOD MOD) 
            igSwapBinpIPresIGWlsBinpSTR (errMOD MOD)"
  using imp_igSwapInpIPresIGWlsInpSTR
        imp_igSwapBinpIPresIGWlsBinpSTR by auto
  fix zs::'varSort and z1 z2 ::'var and delta einp ebinp
  let ?Left = "eSwap MOD zs z1 z2 (eOp MOD delta einp ebinp)"
  let ?einpsw = "eSwapInp MOD zs z1 z2 einp"
  let ?ebinpsw = "eSwapBinp MOD zs z1 z2 ebinp"
  let ?Right = "eOp MOD delta ?einpsw ?ebinpsw"
  show "?Left = ?Right"
  proof(cases "liftAll (λeX. eX  ERR) einp 
               liftAll (λeA. eA  ERR) ebinp")
    case True note t = True
    moreover obtain inp and binp where
    "inp = checkI einp" and  "binp = checkI ebinp" by blast
    ultimately have einp: "einp = OKI inp"   "ebinp = OKI binp" by auto
    show ?thesis
    proof(cases "igWlsInp MOD delta inp  igWlsBinp MOD delta binp")
      case False
      hence "?Left = ERR" unfolding einp by auto
      have "¬ (eWlsInp MOD delta einp  eWlsBinp MOD delta ebinp)"
      unfolding einp using False by auto
      hence 2: "¬ (eWlsInp MOD delta ?einpsw  eWlsBinp MOD delta ?ebinpsw)"
      using 1 unfolding igSwapInpIPresIGWlsInpSTR_def
                             igSwapBinpIPresIGWlsBinpSTR_def by auto
      {fix X assume "?Right = OK X"
       then obtain inpsw and binpsw
       where "?einpsw = OKI inpsw" and "?ebinpsw = OKI binpsw"
       and "igWlsInp MOD delta inpsw" and "igWlsBinp MOD delta binpsw"
       and "X = igOp MOD delta inpsw binpsw"
       using eOp_invert[of MOD delta ?einpsw ?ebinpsw X] by auto
       hence False using 2 by auto
      } 
      with ?Left = ERR› show ?thesis by (cases ?Right) auto
    next
      case True  
      moreover have "igWls MOD (stOf delta) (igOp MOD delta inp binp)"
      using True ‹igOpIPresIGWls MOD unfolding igOpIPresIGWls_def by simp
      moreover have "igWlsInp MOD delta (igSwapInp MOD zs z1 z2 inp) 
                     igWlsBinp MOD delta (igSwapBinp MOD zs z1 z2 binp)"
      using 0 unfolding igSwapInpIPresIGWlsInp_def igSwapBinpIPresIGWlsBinp_def
      using True by simp
      ultimately show ?thesis using ‹igSwapIGOp MOD unfolding einp igSwapIGOp_def by auto
    qed
  qed auto
qed

lemma errMOD_igSwapClsSTR:
assumes "igWlsAllDisj MOD" and "igWlsDisj MOD"
and "igWlsAbsIsInBar MOD" and "igConsIPresIGWls MOD"
and "igSwapAllIPresIGWlsAll MOD" and "igSwapCls MOD"
shows "igSwapClsSTR (errMOD MOD)"
using assms
unfolding igWlsAllDisj_def igConsIPresIGWls_def igSwapCls_def
igSwapAllIPresIGWlsAll_def igSwapClsSTR_def
using
errMOD_igSwapIGVarSTR[of MOD]
errMOD_igSwapIGAbsSTR[of MOD]
errMOD_igSwapIGOpSTR[of MOD]
by simp

text‹The strong ``subst" clauses are satisfied:›

lemma errMOD_igSubstIGVar1STR:
assumes "igVarIPresIGWls MOD" and "igSubstIGVar1 MOD"
shows "igSubstIGVar1STR (errMOD MOD)"
using assms  
by (simp add: igSubstIGVar1STR_def igVarIPresIGWls_def igSubstIGVar1_def)
   (metis eSubst_simp1 eWls_invert)

lemma errMOD_igSubstIGVar2STR:
assumes "igVarIPresIGWls MOD" and "igSubstIGVar2 MOD"
shows "igSubstIGVar2STR (errMOD MOD)"
using assms  
by (simp add: igSubstIGVar2STR_def igVarIPresIGWls_def igSubstIGVar2_def) 
   (metis eSubst_simp1 eWls_invert)

lemma errMOD_igSubstIGAbsSTR:
fixes MOD :: "('index,'bindex,'varSort,'sort,'opSym,'var,'gTerm,'gAbs)model"
assumes *: "igAbsIPresIGWls MOD" and **: "igWlsDisj MOD"
and ***: "igSubstIPresIGWls MOD" and ****: "igSubstIGAbs MOD"
shows "igSubstIGAbsSTR (errMOD MOD)"
unfolding igSubstIGAbsSTR_def proof(clarify)
  fix ys xs ::'varSort and y x ::'var and eX eY
  assume diff: "xs  ys  x  y"
  and x_fresh_Y: "eFresh MOD xs x eY"
  show "eSubstAbs MOD ys eY y (eAbs MOD xs x eX) =
        eAbs MOD xs x (eSubst MOD ys eY y eX)"
  proof(cases "eX  ERR  eY  ERR")
    case True
    define X and Y where "X  check eX" and "Y  check eY"
    hence eX: "eX = OK X" and eY: "eY = OK Y" unfolding X_def Y_def
    using True OK_check by auto
    show ?thesis 
    proof(cases "( s. isInBar (xs,s)  igWls MOD s X)  igWls MOD (asSort ys) Y")
      case True 
      then obtain s where xs_s: "isInBar (xs, s)" and X: "igWls MOD s X" 
      and Y: "igWls MOD (asSort ys) Y" by auto
      hence "igWlsAbs MOD (xs,s) (igAbs MOD xs x X)"
      using * unfolding igAbsIPresIGWls_def by simp
      moreover have "igWls MOD s (igSubst MOD ys Y y X)"
      using X Y *** unfolding igSubstIPresIGWls_def by simp
      moreover have "igFresh MOD xs x Y"
      using x_fresh_Y Y unfolding eY by simp
      ultimately show ?thesis unfolding eX eY
      using xs_s X Y apply simp
      using x_fresh_Y diff **** unfolding igSubstIGAbs_def by fastforce
    next
      case False 
      show ?thesis 
      proof(cases "(EX s. igWls MOD s X)  igWls MOD (asSort ys) Y")
        case True
        then obtain s where X: "igWls MOD s X" and Y: "igWls MOD (asSort ys) Y" by auto
        hence 2: "~ isInBar (xs,s)" using False by (auto simp: eX eY)
        let ?Xsb = "igSubst MOD ys Y y X"
        have Xsb: "igWls MOD s ?Xsb"
        using Y X *** unfolding igSubstIPresIGWls_def by auto
        {fix s' assume 3: "isInBar (xs,s')" and "igWls MOD s' ?Xsb"
         hence "s = s'" using Xsb ** unfolding igWlsDisj_def by auto
         hence False using 2 3 by (simp add: eX eY)
        }
        thus ?thesis using False Y eAbs_simp2 X eX eY by fastforce
      qed(auto simp add: eX eY)
    qed
  qed auto
qed

lemma errMOD_igSubstIGOpSTR:
assumes "igWlsAbsIsInBar MOD"
and "igVarIPresIGWls MOD" and "igOpIPresIGWls MOD"
and "igSubstIPresIGWls MOD" and "igSubstAbsIPresIGWlsAbs MOD"
and "igWlsDisj MOD" and "igWlsAbsDisj MOD"
and "igSubstIGOp MOD"
shows "igSubstIGOpSTR (errMOD MOD)"
proof-
  have 0: "igSubstInpIPresIGWlsInp MOD  igSubstBinpIPresIGWlsBinp MOD"
  using ‹igSubstIPresIGWls MOD ‹igSubstAbsIPresIGWlsAbs MOD
  imp_igSubstInpIPresIGWlsInp imp_igSubstBinpIPresIGWlsBinp by auto
  have "igSubstIPresIGWlsSTR (errMOD MOD)  igSubstAbsIPresIGWlsAbsSTR (errMOD MOD)"
  using assms errMOD_igSubstIPresIGWlsSTR errMOD_igSubstAbsIPresIGWlsAbsSTR by auto
  hence 1: "igSubstInpIPresIGWlsInpSTR (errMOD MOD) 
            igSubstBinpIPresIGWlsBinpSTR (errMOD MOD)"
  using imp_igSubstInpIPresIGWlsInpSTR imp_igSubstBinpIPresIGWlsBinpSTR by auto
  show ?thesis
  unfolding igSubstIGOpSTR_def proof safe
    fix ys::'varSort and y y1 ::'var and delta einp ebinp
    let ?Left = "eSubst MOD ys (eVar MOD ys y1) y (eOp MOD delta einp ebinp)"
    let ?einpsb = "eSubstInp MOD ys (eVar MOD ys y1) y einp"
    let ?ebinpsb = "eSubstBinp MOD ys (eVar MOD ys y1) y ebinp"
    let ?Right = "eOp MOD delta ?einpsb ?ebinpsb"
    show "?Left = ?Right"
    proof(cases "liftAll (λeX. eX  ERR) einp  liftAll (λeA. eA  ERR) ebinp")
      case True 
      moreover obtain inp binp where
      "inp = checkI einp" and "binp = checkI ebinp" by blast
      ultimately have einp: "einp = OKI inp"  "ebinp = OKI binp"  by auto
      have igWls_y1: "igWls MOD (asSort ys) (igVar MOD ys y1)"
      using ‹igVarIPresIGWls MOD unfolding igVarIPresIGWls_def by simp
      show ?thesis
      proof(cases "igWlsInp MOD delta inp  igWlsBinp MOD delta binp")
        case False
        hence "?Left = ERR" unfolding einp by auto
        have "¬ (eWlsInp MOD delta einp  eWlsBinp MOD delta ebinp)"
        unfolding einp using False by simp
        hence 2: "¬ (eWlsInp MOD delta ?einpsb  eWlsBinp MOD delta ?ebinpsb)"
        using igWls_y1 1
        unfolding igSubstInpIPresIGWlsInpSTR_def igSubstBinpIPresIGWlsBinpSTR_def by simp
        {fix X assume "?Right = OK X"
         then obtain inpsb binpsb where
         "?einpsb = OKI inpsb" and "?ebinpsb = OKI binpsb"
         and "igWlsInp MOD delta inpsb" and "igWlsBinp MOD delta binpsb"
         and "X = igOp MOD delta inpsb binpsb"
         using eOp_invert[of MOD delta ?einpsb ?ebinpsb X] by auto
         hence False using 2 by auto
        }
        hence "?Right = ERR" by (cases ?Right, auto)
        with ?Left = ERR› show ?thesis by simp
      next
        case True
        moreover have "igWls MOD (stOf delta) (igOp MOD delta inp binp)"
        using True ‹igOpIPresIGWls MOD unfolding igOpIPresIGWls_def by simp
        moreover
        have "igWlsInp MOD delta (igSubstInp MOD ys (igVar MOD ys y1) y inp) 
              igWlsBinp MOD delta (igSubstBinp MOD ys (igVar MOD ys y1) y binp)"
        using 0 unfolding igSubstInpIPresIGWlsInp_def igSubstBinpIPresIGWlsBinp_def
        using True igWls_y1 by simp
        ultimately show ?thesis
        using ‹igSubstIGOp MOD igWls_y1 unfolding einp igSubstIGOp_def by auto
      qed
    qed auto
  next
    fix ys::'varSort and y ::'var and eY delta einp ebinp
    assume eY: "eWls MOD (asSort ys) eY"
    let ?Left = "eSubst MOD ys eY y (eOp MOD delta einp ebinp)"
    let ?einpsb = "eSubstInp MOD ys eY y einp"
    let ?ebinpsb = "eSubstBinp MOD ys eY y ebinp"
    let ?Right = "eOp MOD delta ?einpsb ?ebinpsb"
    from eY obtain Y where eY_def: "eY = OK Y"
    and Y: "igWls MOD (asSort ys) Y" using eWls_invert[of MOD "asSort ys" eY] by auto
    show "?Left = ?Right"
    proof(cases "liftAll (λeX. eX  ERR) einp  liftAll (λeA. eA  ERR) ebinp")
      case True
      moreover obtain inp binp where
      "inp = checkI einp" and "binp = checkI ebinp" by blast
      ultimately have einp: "einp = OKI inp"  "ebinp = OKI binp" by auto
      show ?thesis
      proof(cases "igWlsInp MOD delta inp  igWlsBinp MOD delta binp")
        case False
        hence "?Left = ERR" unfolding einp by auto
        have "¬ (eWlsInp MOD delta einp  eWlsBinp MOD delta ebinp)"
        unfolding einp using False by simp
        hence 2: "¬ (eWlsInp MOD delta ?einpsb  eWlsBinp MOD delta ?ebinpsb)"
        unfolding eY_def using Y 1
        unfolding igSubstInpIPresIGWlsInpSTR_def igSubstBinpIPresIGWlsBinpSTR_def by simp
        {fix X assume "?Right = OK X"
         then obtain inpsb binpsb
         where "?einpsb = OKI inpsb" and "?ebinpsb = OKI binpsb"
         and "igWlsInp MOD delta inpsb" and "igWlsBinp MOD delta binpsb"
         and "X = igOp MOD delta inpsb binpsb"
         using eOp_invert[of MOD delta ?einpsb ?ebinpsb X] by auto
         hence False using 2 by auto
        }
        hence "?Right = ERR" by (cases ?Right, auto)
        with ?Left = ERR› show ?thesis by simp
      next
        case True
        moreover have "igWls MOD (stOf delta) (igOp MOD delta inp binp)"
        using True ‹igOpIPresIGWls MOD unfolding igOpIPresIGWls_def by simp
        moreover
        have "igWlsInp MOD delta (igSubstInp MOD ys Y y inp) 
              igWlsBinp MOD delta (igSubstBinp MOD ys Y y binp)"
        using 0 unfolding igSubstInpIPresIGWlsInp_def igSubstBinpIPresIGWlsBinp_def
        using True Y by simp
        ultimately show ?thesis unfolding einp eY_def 
        using ‹igSubstIGOp MOD Y unfolding igSubstIGOp_def by auto
      qed
    qed auto
  qed
qed

lemma errMOD_igSubstClsSTR:
assumes "igWlsAllDisj MOD" and "igConsIPresIGWls MOD"
and "igWlsAbsIsInBar MOD"
and "igSubstAllIPresIGWlsAll MOD" and "igSubstCls MOD"
shows "igSubstClsSTR (errMOD MOD)"
using assms
unfolding igWlsAllDisj_def igConsIPresIGWls_def igSubstCls_def
igSubstAllIPresIGWlsAll_def igSubstClsSTR_def
using
errMOD_igSubstIGVar1STR[of MOD] errMOD_igSubstIGVar2STR[of MOD]
errMOD_igSubstIGAbsSTR[of MOD]
errMOD_igSubstIGOpSTR[of MOD]
by simp

text‹Strong swap-based congruence for abstractions holds:›

lemma errMOD_igAbsCongSSTR:
assumes "igSwapIPresIGWls MOD" and "igWlsDisj MOD" and "igAbsCongS MOD"
shows "igAbsCongSSTR (errMOD MOD)"
unfolding igAbsCongSSTR_def proof(clarify)
  fix xs ::'varSort and x x' y ::'var and eX eX'
  assume *: "eFresh MOD xs y eX" and **: "eFresh MOD xs y eX'"
  and ***: "eSwap MOD xs y x eX = eSwap MOD xs y x' eX'"
  let ?phi = "λeX. eX = ERR  ( X. eX = OK X  ( s. ¬ igWls MOD s X))"
  have 1: "?phi eX = ?phi eX'"
  proof
    assume "?phi eX"
    {fix X' s' assume "eX' = OK X'  ( s. igWls MOD s X')"
     hence "ERR = OK (igSwap MOD xs y x' X')" using ?phi eX *** by auto
    }
    thus "?phi eX'" by(cases eX', auto)
  next
    assume "?phi eX'"
    {fix X assume "eX = OK X  ( s. igWls MOD s X)"
     hence "ERR = OK (igSwap MOD xs y x X)" using ?phi eX' *** by auto
    }
    thus "?phi eX" by(cases eX, auto)
  qed
  show "eAbs MOD xs x eX = eAbs MOD xs x' eX'"
  proof(cases "?phi eX")
    case True
    thus ?thesis using 1 by auto
  next
    case False
    then obtain s X where eX: "eX = OK X" and X_wls: "igWls MOD s X" by(cases eX, auto)
    obtain s' X' where eX': "eX' = OK X'" and X'_wls: "igWls MOD s' X'"
    using ¬ ?phi eX 1 by(cases eX') auto
    hence "igSwap MOD xs y x X = igSwap MOD xs y x' X'"
    using eX X_wls *** by auto
    moreover have "igWls MOD s (igSwap MOD xs y x X)"
    using X_wls ‹igSwapIPresIGWls MOD unfolding igSwapIPresIGWls_def by simp
    moreover have "igWls MOD s' (igSwap MOD xs y x' X')"
    using X'_wls ‹igSwapIPresIGWls MOD unfolding igSwapIPresIGWls_def by simp
    ultimately have "s' = s" using ‹igWlsDisj MOD unfolding igWlsDisj_def by auto
    show ?thesis
    proof (cases "isInBar (xs,s)")
      case True
      have "igFresh MOD xs y X" using * X_wls unfolding eX by simp
      moreover have "igFresh MOD xs y X'" using ** X'_wls unfolding eX' by simp
      moreover have "igSwap MOD xs y x X = igSwap MOD xs y x' X'"
      using *** X_wls X'_wls unfolding eX eX' by simp
      ultimately show ?thesis  
      unfolding eX eX' 
      using X_wls X'_wls unfolding s' = s
      using ‹igAbsCongS MOD True unfolding igAbsCongS_def 
      by (metis FixSyn.eCons_simps(2) FixSyn_axioms)
    next
      case False
      {fix s'' assume xs_s'': "isInBar (xs,s'')" and "igWls MOD s'' X"
       hence "s = s''" using X_wls ‹igWlsDisj MOD unfolding igWlsDisj_def by auto
       hence False using False xs_s'' by simp
      }
      moreover
      {fix s'' assume xs_s'': "isInBar (xs,s'')" and "igWls MOD s'' X'"
       hence "s = s''" using X'_wls ‹igWlsDisj MOD unfolding igWlsDisj_def s' = s by auto
       hence False using False xs_s'' by simp
      }
      ultimately show ?thesis 
      using eX eX' X_wls X'_wls unfolding s' = s by fastforce
    qed
  qed
qed

text‹The renaming clause for abstractions holds:›

lemma errMOD_igAbsRenSTR:
assumes "igVarIPresIGWls MOD" and "igSubstIPresIGWls MOD"
and "igWlsDisj MOD" and "igAbsRen MOD"
shows "igAbsRenSTR (errMOD MOD)"
using assms unfolding igAbsRenSTR_def apply clarify
subgoal for xs y x eX
apply(cases eX)
 subgoal by auto
 subgoal for X
 apply(cases "EX s. isInBar (xs,s)  igWls MOD s X")
   subgoal by (auto simp: igVarIPresIGWls_def igSubstIPresIGWls_def igAbsRen_def) 
   subgoal using assms by (simp add: igVarIPresIGWls_def igSubstIPresIGWls_def igAbsRen_def igWlsDisj_def)   
     (metis eAbs_simp2 eAbs_simp3  eSubst_simp1 eSubst_simp3) . . .

text‹Strong subst-based congruence for abstractions holds:›

corollary errMOD_igAbsCongUSTR:
assumes "igVarIPresIGWls MOD" and "igSubstIPresIGWls MOD"
and "igWlsDisj MOD" and "igAbsRen MOD"
shows "igAbsCongUSTR (errMOD MOD)"
using assms errMOD_igAbsRenSTR igAbsRenSTR_imp_igAbsCongUSTR by auto

text‹The error model is a strongly well-sorted fresh-swap model:›

lemma errMOD_iwlsFSwSTR:
fixes MOD :: "('index,'bindex,'varSort,'sort,'opSym,'var,'gTerm,'gAbs) model"
assumes "iwlsFSw MOD"
shows "iwlsFSwSTR (errMOD MOD)"
using assms unfolding iwlsFSw_def iwlsFSwSTR_def
using errMOD_igWlsAllDisj[of MOD]
errMOD_igWlsAbsIsInBar[of MOD]
errMOD_igConsIPresIGWlsSTR[of MOD]
errMOD_igSwapAllIPresIGWlsAllSTR[of MOD]
errMOD_igFreshClsSTR[of MOD] errMOD_igSwapClsSTR[of MOD]
errMOD_igAbsCongSSTR[of MOD]
apply simp
unfolding igSwapAllIPresIGWlsAll_def igWlsAllDisj_defs by simp

text‹The error model is a strongly well-sorted fresh-subst model:›

lemma errMOD_iwlsFSbSwTR:
fixes MOD :: "('index,'bindex,'varSort,'sort,'opSym,'var,'gTerm,'gAbs) model"
assumes "iwlsFSb MOD"
shows "iwlsFSbSwTR (errMOD MOD)"
using assms unfolding iwlsFSb_def iwlsFSbSwTR_def
using errMOD_igWlsAllDisj[of MOD]
errMOD_igWlsAbsIsInBar[of MOD]
errMOD_igConsIPresIGWlsSTR[of MOD]
errMOD_igSubstAllIPresIGWlsAllSTR[of MOD]
errMOD_igFreshClsSTR[of MOD] errMOD_igSubstClsSTR[of MOD]
errMOD_igAbsRenSTR[of MOD]
by (simp add: igConsIPresIGWls_def igSubstAllIPresIGWlsAll_def igWlsAllDisj_defs) 

subsubsection ‹The natural morhpism from an error model to its original model›

text‹This morphism is igiven by the ``check" functions.›

text‹Preservation of the domains:›

lemma check_ipresIGWls:
"ipresIGWls check (errMOD MOD) MOD"
unfolding ipresIGWls_def apply clarify
subgoal for _ X by(cases X) auto .

lemma check_ipresIGWlsAbs:
"ipresIGWlsAbs check (errMOD MOD) MOD"
unfolding ipresIGWlsAbs_def apply clarify
subgoal for _ _ A by(cases A) auto .

lemma check_ipresIGWlsAll:
"ipresIGWlsAll check check (errMOD MOD) MOD"
unfolding ipresIGWlsAll_def
using check_ipresIGWls check_ipresIGWlsAbs by auto

text‹Preservation of the operations:›

lemma check_ipresIGVar:
"ipresIGVar check (errMOD MOD) MOD"
unfolding ipresIGVar_def by simp

lemma check_ipresIGAbs:
"ipresIGAbs check check (errMOD MOD) MOD"
unfolding ipresIGAbs_def apply clarify
subgoal for _ _ _ X by(cases X) auto .

lemma check_ipresIGOp:
"ipresIGOp check check (errMOD MOD) MOD"
unfolding ipresIGOp_def proof clarify
  fix delta einp ebinp
  assume "eWlsInp MOD delta einp" and "eWlsBinp MOD delta ebinp"
  then obtain inp binp where
  "igWlsInp MOD delta inp" and "igWlsBinp MOD delta binp"
  and "einp = OKI inp" and "ebinp = OKI binp"
  using eWlsInp_invert eWlsBinp_invert by blast
  hence "check (eOp MOD delta einp ebinp) =
         igOp MOD delta (checkI einp) (checkI ebinp)" by simp
  thus "check (eOp MOD delta einp ebinp) =
        igOp MOD delta (lift check einp) (lift check ebinp)"
  unfolding checkI_def .
qed

lemma check_ipresIGCons:
"ipresIGCons check check (errMOD MOD) MOD"
unfolding ipresIGCons_def
using
check_ipresIGVar
check_ipresIGAbs
check_ipresIGOp
by auto

lemma check_ipresIGFresh:
"ipresIGFresh check (errMOD MOD) MOD"
unfolding ipresIGFresh_def apply clarify
subgoal for _ _ _ X by(cases X) auto .

lemma check_ipresIGFreshAbs:
"ipresIGFreshAbs check (errMOD MOD) MOD"
unfolding ipresIGFreshAbs_def apply clarify
subgoal for _ _ _ _ A by(cases A) auto .

lemma check_ipresIGFreshAll:
"ipresIGFreshAll check check (errMOD MOD) MOD"
unfolding ipresIGFreshAll_def
using check_ipresIGFresh check_ipresIGFreshAbs by auto

lemma check_ipresIGSwap:
"ipresIGSwap check (errMOD MOD) MOD"
unfolding ipresIGSwap_def apply clarify
subgoal for _ _ _ _ X by(cases X) auto .

lemma check_ipresIGSwapAbs:
"ipresIGSwapAbs check (errMOD MOD) MOD"
unfolding ipresIGSwapAbs_def apply clarify
subgoal for _ _ _ _ _ A by(cases A) auto .

lemma check_ipresIGSwapAll:
"ipresIGSwapAll check check (errMOD MOD) MOD"
unfolding ipresIGSwapAll_def
using check_ipresIGSwap check_ipresIGSwapAbs by auto

lemma check_ipresIGSubst:
"ipresIGSubst check (errMOD MOD) MOD"
unfolding ipresIGSubst_def apply clarify
subgoal for _ Y _ _  X by (cases X, simp, cases Y) auto .

lemma check_ipresIGSubstAbs:
"ipresIGSubstAbs check check (errMOD MOD) MOD"
unfolding ipresIGSubstAbs_def apply clarify
subgoal for _ Y _ _ _ A by (cases A, simp, cases Y) auto .

lemma check_ipresIGSubstAll:
"ipresIGSubstAll check check (errMOD MOD) MOD"
unfolding ipresIGSubstAll_def
using check_ipresIGSubst check_ipresIGSubstAbs by auto

text‹``check" is a fresh-swap morphism:›

lemma check_FSwImorph:
"FSwImorph check check (errMOD MOD) MOD"
unfolding FSwImorph_def
using check_ipresIGWlsAll check_ipresIGCons
check_ipresIGFreshAll check_ipresIGSwapAll by auto

text‹``check" is a fresh-subst morphism:›

lemma check_FSbImorph:
"FSbImorph check check (errMOD MOD) MOD"
unfolding FSbImorph_def
using check_ipresIGWlsAll check_ipresIGCons
check_ipresIGFreshAll check_ipresIGSubstAll by auto

subsection ‹Initiality of the models of terms›

text ‹We show that terms form initial models in all the considered kinds.
The desired initial morphism will be the composition of ``check" with the
factorization of the standard (absolute-initial) function from quasi-terms, ``qInit",
to alpha-equivalence.
``qInit" preserving alpha-equivalence (in an unsorted fashion)
was the main reason for introducing error models.›

(* Here we need to switch back for a while to the quasi-term ``implementation" of terms: *)

declare qItem_simps[simp]
declare qItem_versus_item_simps[simp]
declare good_item_simps[simp]

subsubsection ‹The initial map from quasi-terms to a strong model›

(* The next is needed in the termination arigument for ``qInit": *)

definition
aux_qInit_ignoreFirst ::
"('index,'bindex,'varSort,'sort,'opSym,'var,'gTerm,'gAbs)model *
 ('index,'bindex,'varSort,'var,'opSym)qTerm +
 ('index,'bindex,'varSort,'sort,'opSym,'var,'gTerm,'gAbs)model *
 ('index,'bindex,'varSort,'var,'opSym)qAbs 
 ('index,'bindex,'varSort,'var,'opSym)qTermItem"
where
"aux_qInit_ignoreFirst K =
 (case K of Inl (MOD,qX)  termIn qX
           |Inr (MOD,qA)  absIn qA)"

lemma qTermLess_ingoreFirst_wf:
"wf (inv_image qTermLess aux_qInit_ignoreFirst)"
using qTermLess_wf wf_inv_image by auto

function
qInit :: "('index,'bindex,'varSort,'sort,'opSym,'var,'gTerm,'gAbs)model 
          ('index,'bindex,'varSort,'var,'opSym)qTerm  'gTerm"
and
qInitAbs :: "('index,'bindex,'varSort,'sort,'opSym,'var,'gTerm,'gAbs)model 
          ('index,'bindex,'varSort,'var,'opSym)qAbs  'gAbs"
where
"qInit MOD (qVar xs x) = igVar MOD xs x"
|
"qInit MOD (qOp delta qinp qbinp) =
 igOp MOD delta (lift (qInit MOD) qinp) (lift (qInitAbs MOD) qbinp)"
|
"qInitAbs MOD (qAbs xs x qX) = igAbs MOD xs x (qInit MOD qX)"
by(pat_completeness) auto
termination
apply(relation "inv_image qTermLess aux_qInit_ignoreFirst")
apply(simp add: qTermLess_ingoreFirst_wf)
by(auto simp: qTermLess_def aux_qInit_ignoreFirst_def)

lemma qFreshAll_igFreshAll_qInitAll:
assumes "igFreshClsSTR MOD"
shows
"(qFresh ys y qX  igFresh MOD ys y (qInit MOD qX)) 
 (qFreshAbs ys y qA  igFreshAbs MOD ys y (qInitAbs MOD qA))"
apply(induct rule: qTerm_rawInduct)
using assms 
by (auto simp: igFreshClsSTR_def igFreshIGVar_def qFreshInp_def qFreshBinp_def liftAll_lift_comp
  liftAll_def igFreshInp_def igFreshBinp_def lift_def igFreshIGAbs1STR_def igFreshIGAbs2STR_def igFreshIGOpSTR_def
  split: option.splits)

corollary iwlsFSwSTR_qFreshAll_igFreshAll_qInitAll:
assumes "iwlsFSwSTR MOD"
shows
"(qFresh ys y qX  igFresh MOD ys y (qInit MOD qX)) 
 (qFreshAbs ys y qA  igFreshAbs MOD ys y (qInitAbs MOD qA))"
using assms unfolding iwlsFSwSTR_def by(simp add: qFreshAll_igFreshAll_qInitAll)

corollary iwlsFSbSwTR_qFreshAll_igFreshAll_qInitAll:
assumes "iwlsFSbSwTR MOD"
shows
"(qFresh ys y qX  igFresh MOD ys y (qInit MOD qX)) 
 (qFreshAbs ys y qA  igFreshAbs MOD ys y (qInitAbs MOD qA))"
using assms unfolding iwlsFSbSwTR_def by(simp add: qFreshAll_igFreshAll_qInitAll)

lemma qSwapAll_igSwapAll_qInitAll:
assumes "igSwapClsSTR MOD"
shows
"qInit MOD (qX #[[ z1  z2]]_zs) = igSwap MOD zs z1 z2 (qInit MOD qX) 
 qInitAbs MOD (qA $[[z1  z2]]_zs) = igSwapAbs MOD zs z1 z2 (qInitAbs MOD qA)"
proof(induction rule: qTerm_rawInduct)
  case (Var xs x)
  then show ?case using assms unfolding igSwapClsSTR_def igSwapIGVar_def by simp
next
  case (Op delta qinp qbinp) 
  hence "lift (qInit MOD) (qSwapInp zs z1 z2 qinp) =
        igSwapInp MOD zs z1 z2 (lift (qInit MOD) qinp) 
        lift (qInitAbs MOD) (qSwapBinp zs z1 z2 qbinp) =
        igSwapBinp MOD zs z1 z2 (lift (qInitAbs MOD) qbinp)"
  using Op.IH by (auto simp: qSwapInp_def qSwapBinp_def igSwapInp_def lift_def liftAll_def 
  igSwapBinp_def iwlsFSwSTR_def igSwapClsSTR_def igSwapIGOpSTR_def
  split: option.splits)
  thus ?case 
  using assms unfolding iwlsFSwSTR_def igSwapClsSTR_def igSwapIGOpSTR_def by simp
next
  case (Abs xs x X)
  then show ?case using assms unfolding igSwapClsSTR_def igSwapIGAbsSTR_def by simp
qed 

corollary iwlsFSwSTR_qSwapAll_igSwapAll_qInitAll:
assumes wls: "iwlsFSwSTR MOD"
shows
"qInit MOD (qX #[[ z1  z2]]_zs) = igSwap MOD zs z1 z2 (qInit MOD qX) 
 qInitAbs MOD (qA $[[z1  z2]]_zs) = igSwapAbs MOD zs z1 z2 (qInitAbs MOD qA)"
using assms unfolding iwlsFSwSTR_def by(simp add: qSwapAll_igSwapAll_qInitAll)

lemma qSwapAll_igSubstAll_qInitAll:
fixes qX::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      qA::"('index,'bindex,'varSort,'var,'opSym)qAbs"
assumes *: "igSubstClsSTR MOD"  and "igFreshClsSTR MOD"
and "igAbsRenSTR MOD"
shows
"(qGood qX 
  ( ys y1 y.
     qAFresh ys y1 qX 
     qInit MOD (qX #[[y1  y]]_ys) = igSubst MOD ys (igVar MOD ys y1) y (qInit MOD qX)))
 
 (qGoodAbs qA 
  ( ys y1 y.
     qAFreshAbs ys y1 qA 
     qInitAbs MOD (qA $[[y1  y]]_ys) = igSubstAbs MOD ys (igVar MOD ys y1) y (qInitAbs MOD qA)))"
proof(induction rule: qGood_qTerm_induct)
  case (Var xs x)
  show ?case apply safe 
  subgoal for ys y1 y using * 
  by (cases "ys = xs  y = x")
     (auto simp:  igSubstClsSTR_defs igSubstIGVar2STR_def igSubstClsSTR_defs igSubstIGVar1STR_def).
next
  let ?h = "qInit MOD"  let ?hA = "qInitAbs MOD"
  case (Op delta qinp qbinp)
  then show ?case proof safe
    fix ys y1 y  
    assume ***: "qAFresh ys y1 (qOp delta qinp qbinp)"
    have "lift ?h (qSwapInp ys y1 y qinp) =
        igSubstInp MOD ys (igVar MOD ys y1) y (lift ?h qinp) 
        lift ?hA (qSwapBinp ys y1 y qbinp) =
        igSubstBinp MOD ys (igVar MOD ys y1) y (lift ?hA qbinp)"
    using Op.IH ***
    by (auto simp: qSwapInp_def igSubstInp_def qSwapBinp_def igSubstBinp_def 
      lift_def liftAll_def split: option.splits)
    thus "qInit MOD (qOp delta qinp qbinp #[[y1  y]]_ys) =
       igSubst MOD ys (igVar MOD ys y1) y (qInit MOD (qOp delta qinp qbinp))"
    using assms unfolding iwlsFSwSTR_def igSubstClsSTR_defs igSubstIGOpSTR_def by simp
  qed
next
  let ?h = "qInit MOD"  let ?hA = "qInitAbs MOD"
  case (Abs xs x qX)
  show ?case proof safe 
    fix ys y1 y  
    let ?xy1y = "x @xs[y1  y]_ys"  let ?y1 = "igVar MOD ys y1"
    assume "qAFreshAbs ys y1 (qAbs xs x qX)"
    hence y1_fresh: "ys = xs  y1  x"   "qAFresh ys y1 qX" by auto
    hence 1: "qFresh ys y1 qX" using qAFresh_imp_qFresh by auto
    hence y1_fresh_qX: "igFresh MOD ys y1 (?h qX)"
    using assms unfolding igSubstClsSTR_def
    by(simp add: qFreshAll_igFreshAll_qInitAll)
    (* *)
    obtain x1 where x1_fresh: "x1  {y,y1}"  "qFresh xs x1 qX"  "qAFresh xs x1 qX"
    using obtain_qFresh[of "{y,y1}" "{qX}"] using Abs by blast
    hence [simp]: "igFresh MOD xs x1 (?h qX)"
    using assms by(simp add: qFreshAll_igFreshAll_qInitAll)
    let ?x1 = "igVar MOD xs x1"   let ?x1y1y = "x1 @xs[y1  y]_ys"
    let ?qX_x1x = "qX #[[x1  x]]_xs"  let ?qX_x1x_y1y = "?qX_x1x #[[y1  y]]_ys"
    let ?qX_y1y = "qX #[[y1  y]]_ys" let ?qX_y1y_x1_xy1y = "?qX_y1y #[[x1  ?xy1y]]_xs"
    let ?qX_y1y_x1y1y_xy1y = "?qX_y1y #[[?x1y1y  ?xy1y]]_xs"
    have [simp]: "qAFresh ys y1 ?qX_x1x"
    using y1_fresh x1_fresh by(auto simp add: qSwap_preserves_qAFresh_distinct)
    have [simp]: "qAFresh xs x1 ?qX_y1y"
    using y1_fresh x1_fresh by(auto simp add: qSwap_preserves_qAFresh_distinct)
    hence "qFresh xs x1 ?qX_y1y" by (simp add: qAFresh_imp_qFresh)
    hence [simp]: "igFresh MOD xs x1 (?h ?qX_y1y)"
    using assms by(simp add: qFreshAll_igFreshAll_qInitAll)
    have [simp]: "igFresh MOD xs x1 ?y1"
    using x1_fresh assms  unfolding igFreshClsSTR_def igFreshIGVar_def by simp
    have x1_def: "x1 = ?x1y1y" using x1_fresh by simp
    (*  *)
    have "?hA ((qAbs xs x qX) $[[y1  y]]_ys) = igAbs MOD xs ?xy1y (?h ?qX_y1y)" by simp
    also have " = igAbs MOD xs x1 (igSubst MOD xs ?x1 ?xy1y (?h ?qX_y1y))"
    using assms unfolding igAbsRenSTR_def by simp
    also have "igSubst MOD xs ?x1 ?xy1y (?h ?qX_y1y) = ?h (?qX_y1y_x1_xy1y)"
    using y1_fresh Abs.IH[of "?qX_y1y"] by(simp add: qSwap_qSwapped)
    also have "?qX_y1y_x1_xy1y = ?qX_y1y_x1y1y_xy1y" using x1_def by simp
    also have " = ?qX_x1x_y1y" apply(rule sym) by(rule qSwap_compose)
    also have "?h ?qX_x1x_y1y = igSubst MOD ys ?y1 y (?h ?qX_x1x)"
    using Abs.IH[of "?qX_x1x"] by(simp add: qSwap_qSwapped)
    also have
    "igAbs MOD xs x1 (igSubst MOD ys ?y1 y (?h ?qX_x1x)) =
     igSubstAbs MOD ys ?y1 y (igAbs MOD xs x1 (?h (?qX_x1x)))"
    using assms unfolding igSubstClsSTR_def igSubstIGAbsSTR_def
    using x1_fresh y1_fresh by simp
    also have "?h (?qX_x1x) = igSubst MOD xs ?x1 x (?h qX)"
    using Abs.IH[of "qX"] x1_fresh by(simp add: qSwapped.Refl)
    also have
    "igAbs MOD xs x1 (igSubst MOD xs ?x1 x (?h qX)) =
     igAbs MOD xs x (?h qX)"
    using assms unfolding igAbsRenSTR_def by simp
    also have "igAbs MOD xs x (?h qX) = ?hA (qAbs xs x qX)"
    using assms by simp
    finally show "?hA ((qAbs xs x qX) $[[y1  y]]_ys) =
        igSubstAbs MOD ys ?y1 y (?hA (qAbs xs x qX))" .
  qed
qed

lemma iwlsFSbSwTR_qSwapAll_igSubstAll_qInitAll:
assumes wls: "iwlsFSbSwTR MOD"
shows
"(qGood qX 
  qAFresh ys y1 qX 
  qInit MOD (qX #[[y1  y]]_ys) = igSubst MOD ys (igVar MOD ys y1) y (qInit MOD qX))
 
 (qGoodAbs qA 
  qAFreshAbs ys y1 qA 
  qInitAbs MOD (qA $[[y1  y]]_ys) = igSubstAbs MOD ys (igVar MOD ys y1) y (qInitAbs MOD qA))"
using assms unfolding iwlsFSbSwTR_def by(simp add: qSwapAll_igSubstAll_qInitAll)

lemma iwlsFSwSTR_alphaAll_qInitAll:
assumes "iwlsFSwSTR MOD"
shows
"( qX'. qX #= qX'  qInit MOD qX = qInit MOD qX') 
 ( qA'. qA $= qA'  qInitAbs MOD qA = qInitAbs MOD qA')"
proof(induction rule: qTerm_induct)
  case (Var xs x)
  then show ?case by(simp add: qVar_alpha_iff) 
next
  case (Op delta qinp qbinp)
  show ?case proof safe
    fix qX'
    assume "qOp delta qinp qbinp #= qX'"
    then obtain qinp' qbinp' where qX': "qX' = qOp delta qinp' qbinp'"
    and *: "sameDom qinp qinp'  sameDom qbinp qbinp'"
    and **: "liftAll2 (λqX qX'. qX #= qX') qinp qinp' 
             liftAll2 (λqA qA'. qA $= qA') qbinp qbinp'"
    using qOp_alpha_iff[of delta qinp qbinp qX'] by auto
    hence "lift (qInit MOD) qinp = lift (qInit MOD) qinp'"
    by (smt Op.IH(1) liftAll2_def liftAll2_lift_ext liftAll_def)
    moreover have "lift (qInitAbs MOD) qbinp = lift (qInitAbs MOD) qbinp'"
    by (smt * ** Op.IH(2) liftAll2_def liftAll2_lift_ext liftAll_def)
    ultimately
    show "qInit MOD (qOp delta qinp qbinp) = qInit MOD qX'" unfolding qX' by simp
  qed
next
  case (Abs xs x qX)
  show ?case proof safe
    fix qA'
    assume "qAbs xs x qX $= qA'"
    then obtain x' y qX' where qA': "qA' = qAbs xs x' qX'"
    and y_not: "y  {x, x'}" and "qAFresh xs y qX"  "qAFresh xs y qX'"
    and alpha: "(qX #[[y  x]]_xs) #= (qX' #[[y  x']]_xs)"
    using qAbs_alphaAbs_iff[of xs x qX qA'] by auto
    hence y_fresh: "qFresh xs y qX  qFresh xs y qX'" using qAFresh_imp_qFresh by auto
    have "(qX, qX #[[y  x]]_xs)  qSwapped" using qSwap_qSwapped by fastforce
    hence "qInit MOD (qX #[[y  x]]_xs) = qInit MOD (qX' #[[y  x']]_xs)"
    using Abs.IH alpha by simp  
    hence "igSwap MOD xs y x (qInit MOD qX) = igSwap MOD xs y x' (qInit MOD qX')"
    using assms by(auto simp: iwlsFSwSTR_qSwapAll_igSwapAll_qInitAll)
    moreover have "igFresh MOD xs y (qInit MOD qX)  igFresh MOD xs y (qInit MOD qX')"
    using y_fresh assms by(auto simp add: iwlsFSwSTR_qFreshAll_igFreshAll_qInitAll)
    ultimately have "igAbs MOD xs x (qInit MOD qX) = igAbs MOD xs x' (qInit MOD qX')"
    using y_not assms unfolding iwlsFSwSTR_def igAbsCongSSTR_def 
    apply clarify by (erule allE[of _ xs], erule allE[of _ x]) blast
    thus "qInitAbs MOD (qAbs xs x qX) = qInitAbs MOD qA'" unfolding qA' by simp
  qed
qed 

corollary iwlsFSwSTR_qInit_respectsP_alpha:
assumes "iwlsFSwSTR MOD" shows "(qInit MOD) respectsP alpha"
unfolding congruentP_def using assms iwlsFSwSTR_alphaAll_qInitAll by blast

corollary iwlsFSwSTR_qInitAbs_respectsP_alphaAbs:
assumes "iwlsFSwSTR MOD" shows "(qInitAbs MOD) respectsP alphaAbs"
unfolding congruentP_def using assms iwlsFSwSTR_alphaAll_qInitAll by blast

lemma iwlsFSbSwTR_alphaAll_qInitAll:
fixes qX::"('index,'bindex,'varSort,'var,'opSym)qTerm" and
      qA::"('index,'bindex,'varSort,'var,'opSym)qAbs"
assumes "iwlsFSbSwTR MOD"
shows
"(qGood qX  ( qX'. qX #= qX'  qInit MOD qX = qInit MOD qX')) 
 (qGoodAbs qA  ( qA'. qA $= qA'  qInitAbs MOD qA = qInitAbs MOD qA'))"
proof(induction rule: qGood_qTerm_induct)
  case (Var xs x)
  then show ?case by(simp add: qVar_alpha_iff) 
next
  case (Op delta qinp qbinp)
  show ?case proof safe
    fix qX'
    assume "qOp delta qinp qbinp #= qX'"
    then obtain qinp' qbinp' where qX': "qX' = qOp delta qinp' qbinp'"
    and *: "sameDom qinp qinp'  sameDom qbinp qbinp'"
    and **: "liftAll2 (λqX qX'. qX #= qX') qinp qinp' 
           liftAll2 (λqA qA'. qA $= qA') qbinp qbinp'"
    using qOp_alpha_iff[of delta qinp qbinp qX'] by auto
    have "lift (qInit MOD) qinp = lift (qInit MOD) qinp'"
    using "*" "**" Op.IH(1) by (simp add: lift_def liftAll2_def liftAll_def
     sameDom_def fun_eq_iff split: option.splits) (metis option.exhaust)
    moreover
    have "lift (qInitAbs MOD) qbinp = lift (qInitAbs MOD) qbinp'"
    using "*" "**" Op.IH(2) by (simp add: lift_def liftAll2_def liftAll_def
     sameDom_def fun_eq_iff split: option.splits) (metis option.exhaust)
    ultimately
    show "qInit MOD (qOp delta qinp qbinp) = qInit MOD qX'"
    unfolding qX' by simp
  qed
next
  case (Abs xs x qX)
  show ?case proof safe
    fix qA'
    assume "qAbs xs x qX $= qA'"  
    then obtain x' y qX' where qA': "qA' = qAbs xs x' qX'"
    and y_not: "y  {x, x'}" and y_afresh: "qAFresh xs y qX"  "qAFresh xs y qX'"
    and alpha: "(qX #[[y  x]]_xs) #= (qX' #[[y  x']]_xs)"
    using qAbs_alphaAbs_iff[of xs x qX qA'] by auto
    hence y_fresh: "qFresh xs y qX  qFresh xs y qX'" using qAFresh_imp_qFresh by auto
    have qX': "qGood qX'" using alpha Abs by(simp add: alpha_qSwap_preserves_qGood1)
    have "(qX, qX #[[y  x]]_xs)  qSwapped" using qSwap_qSwapped by fastforce
    hence "qInit MOD (qX #[[y  x]]_xs) = qInit MOD (qX' #[[y  x']]_xs)"
    using Abs.IH alpha by simp 
    moreover have "qInit MOD (qX #[[y  x]]_xs) = igSubst MOD xs (igVar MOD xs y) x (qInit MOD qX)"
    using Abs y_afresh assms by(simp add: iwlsFSbSwTR_qSwapAll_igSubstAll_qInitAll)
    moreover have "qInit MOD (qX' #[[y  x']]_xs) = igSubst MOD xs (igVar MOD xs y) x' (qInit MOD qX')"
    using qX' y_afresh assms by(simp add: iwlsFSbSwTR_qSwapAll_igSubstAll_qInitAll)
    ultimately
    have "igSubst MOD xs (igVar MOD xs y) x (qInit MOD qX) =
        igSubst MOD xs (igVar MOD xs y) x' (qInit MOD qX')"
    by simp
    moreover have "igFresh MOD xs y (qInit MOD qX)  igFresh MOD xs y (qInit MOD qX')"
    using y_fresh assms by(auto simp add: iwlsFSbSwTR_qFreshAll_igFreshAll_qInitAll)
    moreover have "igAbsCongUSTR MOD"
    using assms unfolding iwlsFSbSwTR_def using igAbsRenSTR_imp_igAbsCongUSTR by auto
    ultimately have "igAbs MOD xs x (qInit MOD qX) = igAbs MOD xs x' (qInit MOD qX')"
    using y_not unfolding igAbsCongUSTR_def apply clarify
    by (erule allE[of _ xs], erule allE[of _ x]) blast
    thus "qInitAbs MOD (qAbs xs x qX) = qInitAbs MOD qA'" unfolding qA' by simp
  qed
qed

corollary iwlsFSbSwTR_qInit_respectsP_alphaGood:
assumes "iwlsFSbSwTR MOD"
shows "(qInit MOD) respectsP alphaGood"
unfolding congruentP_def alphaGood_def
using assms iwlsFSbSwTR_alphaAll_qInitAll by fastforce

corollary iwlsFSbSwTR_qInitAbs_respectsP_alphaAbsGood:
assumes "iwlsFSbSwTR MOD"
shows "(qInitAbs MOD) respectsP alphaAbsGood"
unfolding congruentP_def alphaAbsGood_def
using assms iwlsFSbSwTR_alphaAll_qInitAll by auto

subsubsection ‹The initial morphism (iteration map) from the term model to any strong model›

text ‹This morphism has the same definition for fresh-swap and fresh-subst strong models›

definition iterSTR where
"iterSTR MOD == univ (qInit MOD)"

definition iterAbsSTR where
"iterAbsSTR MOD == univ (qInitAbs MOD)"

lemma iwlsFSwSTR_iterSTR_ipresVar:
assumes "iwlsFSwSTR MOD"
shows "ipresVar (iterSTR MOD) MOD"
using assms by(simp add: ipresVar_def Var_def iterSTR_def iwlsFSwSTR_qInit_respectsP_alpha)

lemma iwlsFSbSwTR_iterSTR_ipresVar:
assumes "iwlsFSbSwTR MOD"
shows "ipresVar (iterSTR MOD) MOD"
using assms by (simp add: ipresVar_def Var_def iterSTR_def iwlsFSbSwTR_qInit_respectsP_alphaGood)
 
lemma iwlsFSwSTR_iterSTR_ipresAbs:
assumes "iwlsFSwSTR MOD"
shows "ipresAbs (iterSTR MOD) (iterAbsSTR MOD) MOD"
unfolding ipresAbs_def proof clarify
  fix xs x s X assume X: "wls s X"
  hence "qGood (pick X)" by(simp add: good_imp_qGood_pick)
  hence 1: "qGoodAbs (qAbs xs x (pick X))" by simp
  have "iterAbsSTR MOD (Abs xs x X) = univ (qInitAbs MOD) (asAbs (qAbs xs x (pick X)))"
  using X unfolding Abs_def iterAbsSTR_def by simp
  also have " = qInitAbs MOD (qAbs xs x (pick X))"
  using assms 1 by(simp add: iwlsFSwSTR_qInitAbs_respectsP_alphaAbs)
  also have " = igAbs MOD xs x (qInit MOD (pick X))" by simp
  also have " = igAbs MOD xs x (iterSTR MOD X)" unfolding iterSTR_def
  unfolding univ_def pick_def ..
  finally show "iterAbsSTR MOD (Abs xs x X) = igAbs MOD xs x (iterSTR MOD X)" .
qed

lemma iwlsFSbSwTR_iterSTR_ipresAbs:
assumes "iwlsFSbSwTR MOD"
shows "ipresAbs (iterSTR MOD) (iterAbsSTR MOD) MOD"
unfolding ipresAbs_def proof clarify
  fix xs x s X assume X: "wls s X"
  hence "qGood (pick X)" by(simp add: good_imp_qGood_pick)
  hence 1: "qGoodAbs (qAbs xs x (pick X))" by simp
  have "iterAbsSTR MOD (Abs xs x X) = univ (qInitAbs MOD) (asAbs (qAbs xs x (pick X)))"
  using X unfolding Abs_def iterAbsSTR_def by simp
  also have " = qInitAbs MOD (qAbs xs x (pick X))"
  using assms 1 by(simp add: iwlsFSbSwTR_qInitAbs_respectsP_alphaAbsGood)
  also have " = igAbs MOD xs x (qInit MOD (pick X))" by simp
  also have " = igAbs MOD xs x (iterSTR MOD X)" unfolding iterSTR_def univ_def
  unfolding univ_def pick_def ..
  finally show "iterAbsSTR MOD (Abs xs x X) = igAbs MOD xs x (iterSTR MOD X)" .
qed

lemma iwlsFSwSTR_iterSTR_ipresOp:
assumes "iwlsFSwSTR MOD"
shows "ipresOp (iterSTR MOD) (iterAbsSTR MOD) MOD"
unfolding ipresOp_def proof clarify
  fix delta inp binp
  assume inp: "wlsInp delta inp"  "wlsBinp delta binp"
  hence "qGoodInp (pickInp inp)  qGoodBinp (pickBinp binp)"
  by(simp add: goodInp_imp_qGoodInp_pickInp goodBinp_imp_qGoodBinp_pickBinp)
  hence 1: "qGood (qOp delta (pickInp inp) (pickBinp binp))" by simp
  have "iterSTR MOD (Op delta inp binp) =
         univ (qInit MOD) (asTerm (qOp delta (pickInp inp) (pickBinp binp)))"
  using inp unfolding Op_def iterSTR_def by simp
  moreover have " = qInit MOD (qOp delta (pickInp inp) (pickBinp binp))"
  using assms 1 by(simp add: iwlsFSwSTR_qInit_respectsP_alpha)
  moreover have " = igOp MOD delta (lift (qInit MOD) (pickInp inp))
                               (lift (qInitAbs MOD) (pickBinp binp))" by auto
  moreover
  have "lift (qInit MOD) (pickInp inp) = lift (iterSTR MOD) inp 
        lift (qInitAbs MOD) (pickBinp binp) = lift (iterAbsSTR MOD) binp"
  unfolding pickInp_def pickBinp_def iterSTR_def iterAbsSTR_def
            lift_comp univ_def[abs_def] comp_def
  unfolding univ_def pick_def by simp
  ultimately
  show "iterSTR MOD (Op delta inp binp) =
        igOp MOD delta (lift (iterSTR MOD) inp) (lift (iterAbsSTR MOD) binp)" by simp
qed

lemma iwlsFSbSwTR_iterSTR_ipresOp:
assumes "iwlsFSbSwTR MOD"
shows "ipresOp (iterSTR MOD) (iterAbsSTR MOD) MOD"
unfolding ipresOp_def proof clarify
  fix delta inp binp
  assume inp: "wlsInp delta inp"  "wlsBinp delta binp"
  hence "qGoodInp (pickInp inp)  qGoodBinp (pickBinp binp)"
  by(simp add: goodInp_imp_qGoodInp_pickInp goodBinp_imp_qGoodBinp_pickBinp)
  hence 1: "qGood (qOp delta (pickInp inp) (pickBinp binp))" by simp
  have "iterSTR MOD (Op delta inp binp) =
         univ (qInit MOD) (asTerm (qOp delta (pickInp inp) (pickBinp binp)))"
  using inp unfolding Op_def iterSTR_def by simp
  moreover have " = qInit MOD (qOp delta (pickInp inp) (pickBinp binp))"
  using assms 1 by(simp add: iwlsFSbSwTR_qInit_respectsP_alphaGood)
  moreover have " = igOp MOD delta (lift (qInit MOD) (pickInp inp))
                                   (lift (qInitAbs MOD) (pickBinp binp))" by simp
  moreover have "lift (qInit MOD) (pickInp inp) = lift (iterSTR MOD) inp 
                 lift (qInitAbs MOD) (pickBinp binp) = lift (iterAbsSTR MOD) binp"
  unfolding pickInp_def pickBinp_def iterSTR_def iterAbsSTR_def
            lift_comp univ_def[abs_def] comp_def
  unfolding univ_def pick_def by simp
  ultimately
  show "iterSTR MOD (Op delta inp binp) =
        igOp MOD delta (lift (iterSTR MOD) inp) (lift (iterAbsSTR MOD) binp)" by simp
qed

lemma iwlsFSwSTR_iterSTR_ipresCons:
assumes "iwlsFSwSTR MOD"
shows "ipresCons (iterSTR MOD) (iterAbsSTR MOD) MOD"
unfolding ipresCons_def using assms
iwlsFSwSTR_iterSTR_ipresVar
iwlsFSwSTR_iterSTR_ipresAbs
iwlsFSwSTR_iterSTR_ipresOp by auto

lemma iwlsFSbSwTR_iterSTR_ipresCons:
assumes "iwlsFSbSwTR MOD"
shows "ipresCons (iterSTR MOD) (iterAbsSTR MOD) MOD"
unfolding ipresCons_def using assms
iwlsFSbSwTR_iterSTR_ipresVar
iwlsFSbSwTR_iterSTR_ipresAbs
iwlsFSbSwTR_iterSTR_ipresOp by auto

lemma iwlsFSwSTR_iterSTR_termFSwImorph:
assumes "iwlsFSwSTR MOD"
shows "termFSwImorph (iterSTR MOD) (iterAbsSTR MOD) MOD"
using assms by (auto simp: iwlsFSwSTR_termFSwImorph_iff intro: iwlsFSwSTR_iterSTR_ipresCons)

corollary iterSTR_termFSwImorph_errMOD:
assumes "iwlsFSw MOD"
shows
"termFSwImorph (iterSTR (errMOD MOD))
             (iterAbsSTR (errMOD MOD))
             (errMOD MOD)"
using assms errMOD_iwlsFSwSTR iwlsFSwSTR_iterSTR_termFSwImorph by auto

lemma iwlsFSbSwTR_iterSTR_termFSbImorph:
assumes "iwlsFSbSwTR MOD"
shows "termFSbImorph (iterSTR MOD) (iterAbsSTR MOD) MOD"
using assms by (auto simp: iwlsFSbSwTR_termFSbImorph_iff intro: iwlsFSbSwTR_iterSTR_ipresCons)

corollary iterSTR_termFSbImorph_errMOD:
assumes "iwlsFSb MOD"
shows
"termFSbImorph (iterSTR (errMOD MOD))
             (iterAbsSTR (errMOD MOD))
             (errMOD MOD)"
using assms errMOD_iwlsFSbSwTR iwlsFSbSwTR_iterSTR_termFSbImorph by auto

(* We are done with the use of quesi-term ``implementations". *)

declare qItem_simps[simp del]
declare qItem_versus_item_simps[simp del]
declare good_item_simps[simp del]

subsubsection ‹The initial morhpism (iteration map) from the term model to any model›

text ‹Again, this morphism has the same definition for fresh-swap and fresh-subst models,
as well as (of course) for fresh-swap-subst and fresh-subst-swap models. (Remember that
there is no such thing as ``fresh-subst-swap" morhpism -- we use the notion of
``fresh-swap-subst" morphism.)›

text ‹Existence of the morphism:›

definition iter where
"iter MOD == check o (iterSTR (errMOD MOD))"

definition iterAbs where
"iterAbs MOD == check o (iterAbsSTR (errMOD MOD))"

theorem iwlsFSw_iterAll_termFSwImorph:
"iwlsFSw MOD  termFSwImorph (iter MOD) (iterAbs MOD) MOD"
using iterSTR_termFSwImorph_errMOD check_FSwImorph
by (auto simp: iter_def iterAbs_def intro: comp_termFSwImorph)
 
theorem iwlsFSb_iterAll_termFSbImorph:
"iwlsFSb MOD  termFSbImorph (iter MOD) (iterAbs MOD) MOD"
using iterSTR_termFSbImorph_errMOD check_FSbImorph
by (auto simp: iter_def iterAbs_def intro: comp_termFSbImorph)
 
theorem iwlsFSwSb_iterAll_termFSwSbImorph:
"iwlsFSwSb MOD  termFSwSbImorph (iter MOD) (iterAbs MOD) MOD"
using iwlsFSw_iterAll_termFSwImorph
by (auto simp: iwlsFSwSb_termFSwSbImorph_iff iwlsFSwSb_def termFSwImorph_def)

theorem iwlsFSbSw_iterAll_termFSwSbImorph:
"iwlsFSbSw MOD  termFSwSbImorph (iter MOD) (iterAbs MOD) MOD"
using iwlsFSb_iterAll_termFSbImorph 
by (auto simp: iwlsFSbSw_termFSwSbImorph_iff iwlsFSbSw_def  termFSbImorph_def)


text ‹Uniqueness of the morphism›

text ‹In fact, already a presumptive construct-preserving map has to be unique:›

lemma ipresCons_unique:
assumes "ipresCons f fA MOD" and "ipresCons ig igA MOD"
shows
"(wls s X  f X = ig X) 
 (wlsAbs (us,s') A  fA A = igA A)"
proof(induction rule: wls_rawInduct)
  case (Var xs x)
  then show ?case using assms unfolding ipresCons_def ipresVar_def by simp
next
  case (Op delta inp binp) 
  hence "lift f inp = lift ig inp  lift fA binp = lift igA binp" 
  using assms  
  apply(simp add: lift_def liftAll2_def sameDom_def fun_eq_iff wlsInp_iff wlsBinp_iff split: option.splits) 
  using not_None_eq by (metis surj_pair)
  thus "f (Op delta inp binp) = ig (Op delta inp binp)"
  using assms unfolding ipresCons_def ipresOp_def by (simp add: Op.IH)
next
  case (Abs s xs x X)
  then show ?case using assms unfolding ipresCons_def ipresAbs_def apply clarify
  by (erule allE[of _ xs], erule allE[of _ x]) fastforce
qed 

theorem iwlsFSw_iterAll_unique_ipresCons:
assumes "iwlsFSw MOD" and "ipresCons h hA MOD"
shows
"(wls s X  h X = iter MOD X) 
 (wlsAbs (us,s') A  hA A = iterAbs MOD A)"
using assms iwlsFSw_iterAll_termFSwImorph 
by (auto simp: termFSwImorph_def intro!: ipresCons_unique) 

theorem iwlsFSb_iterAll_unique_ipresCons:
assumes "iwlsFSb MOD" and "ipresCons h hA MOD"
shows
"(wls s X  h X = iter MOD X) 
 (wlsAbs (us,s') A  hA A = iterAbs MOD A)"
using assms iwlsFSb_iterAll_termFSbImorph
by (auto simp: termFSbImorph_def intro!: ipresCons_unique)  

theorem iwlsFSwSb_iterAll_unique_ipresCons:
assumes "iwlsFSwSb MOD" and "ipresCons h hA MOD"
shows
"(wls s X  h X = iter MOD X) 
 (wlsAbs (us,s') A  hA A = iterAbs MOD A)"
using assms unfolding iwlsFSwSb_def
using iwlsFSw_iterAll_unique_ipresCons by blast

theorem iwlsFSbSw_iterAll_unique_ipresCons:
assumes *: "iwlsFSbSw MOD" and **: "ipresCons h hA MOD"
shows
"(wls s X  h X = iter MOD X) 
 (wlsAbs (us,s') A  hA A = iterAbs MOD A)"
using assms unfolding iwlsFSbSw_def
using iwlsFSb_iterAll_unique_ipresCons by blast

(**************************************)
lemmas iteration_simps =
input_igSwap_igSubst_None
termMOD_simps
error_model_simps

declare iteration_simps [simp del]

end (* context FixSyn *)
(************************************************)

end

Theory Semantic_Domains

section ‹Interpretation of syntax in semantic domains›

theory Semantic_Domains imports Iteration  
begin

text ‹In this section, we employ our iteration principle
to obtain interpretation of syntax in semantic domains via valuations.
A bonus from our Horn-theoretic approach is the built-in
commutation of the interpretation with substitution versus valuation update,
a property known in the literature as the ``substitution lemma".›

subsection ‹Semantic domains and valuations›

text‹
Semantic domains are for binding signatures
what algebras are for standard algebraic signatures. They fix carrier sets for each sort,
and interpret each operation symbol as an operation on these sets
%
\footnote{
To match the Isabelle type system, we model (as usual) the family of carrier sets as a
``well-sortedness" predicate taking sorts and semantic items from a given
(initially unsorted) universe into booleans,
and require the operations, considered on the unsorted universe, to preserve well-sortedness.
}
%
of corresponding arity, where:
%
\\- non-binding arguments
are treated as usual (first-order) arguments;
%
\\- binding arguments are treated as second-order (functional) arguments.
%
\footnote{
In other words, syntactic bindings are captured semantically as functional bindings.}
%

In particular, for the untyped and simply-typed $\lambda$-calculi,
the semantic domains become the well-known (set-theoretic) Henkin models.

We use terminology and notation according to our general methodology employed so far:
the inhabitants of semantic domains are referred to as ``semantic items";
we prefix the reference to semantic items with an ``s": sX, sA, etc.
This convention also applies to the operations on semantic domains: ``sAbs", ``sOp", etc.

We eventually show that the function spaces consisting of maps
from valuations to semantic items form models;
in other words,
these maps can be viewed as ``generalized items"; we use for them
term-like notations ``X", ``A", etc.
(as we did in the theory that dealt with iteration).
›

subsubsection ‹Definitions:›

datatype ('varSort,'sTerm)sAbs = sAbs 'varSort "'sTerm  'sTerm"

record ('index,'bindex,'varSort,'sort,'opSym,'sTerm)semDom =
  sWls :: "'sort  'sTerm  bool"
  sDummy :: "'sort  'sTerm"
  sOp :: "'opSym  ('index,'sTerm)input  ('bindex,('varSort,'sTerm)sAbs)input 'sTerm"

text‹The type of valuations:›

type_synonym ('varSort,'var,'sTerm)val = "'varSort  'var  'sTerm"

(* *************************************************** *)
context FixSyn
begin

(* A new type variable, corresponding to 'sTerm, is introduced in the context by 
the following definitions and facts. *)

fun sWlsAbs where
"sWlsAbs SEM (xs,s) (sAbs xs' sF) =
 (isInBar (xs,s)  xs = xs' 
  ( sX. if sWls SEM (asSort xs) sX
           then sWls SEM s (sF sX)
           else sF sX = sDummy SEM s))"

definition sWlsInp where
"sWlsInp SEM delta sinp 
 wlsOpS delta  sameDom (arOf delta) sinp  liftAll2 (sWls SEM) (arOf delta) sinp"

definition sWlsBinp where
"sWlsBinp SEM delta sbinp 
 wlsOpS delta  sameDom (barOf delta) sbinp  liftAll2 (sWlsAbs SEM) (barOf delta) sbinp"

definition sWlsNE where
"sWlsNE SEM 
  s.  sX. sWls SEM s sX"

definition sWlsDisj where
"sWlsDisj SEM 
  s s' sX. sWls SEM s sX  sWls SEM s' sX  s = s'"

definition sOpPrSWls where
"sOpPrSWls SEM 
  delta sinp sbinp.
   sWlsInp SEM delta sinp  sWlsBinp SEM delta sbinp
    sWls SEM (stOf delta) (sOp SEM delta sinp sbinp)"

text‹The notion of a ``well-sorted" (better read as ``well-structured")
semantic domain: 
%
\footnote{
As usual in Isabelle, we first define the ``raw" version,
and then ``fix" it with a well-structuredness predicate.
}
%
›
definition wlsSEM where
"wlsSEM SEM 
 sWlsNE SEM  sWlsDisj SEM  sOpPrSWls SEM"

text‹The preperties described  in the next 4 definitions turn out to be
consequences of the well-structuredness of the semantic domain:›

definition sWlsAbsNE where
"sWlsAbsNE SEM 
  us s. isInBar (us,s)  ( sA. sWlsAbs SEM (us,s) sA)"

definition sWlsAbsDisj where
"sWlsAbsDisj SEM 
  us s us' s' sA.
   isInBar (us,s)  isInBar (us',s')  sWlsAbs SEM (us,s) sA  sWlsAbs SEM (us',s') sA
    us = us'  s = s'"

text‹The notion of two valuations being equal everywhere but on a given variable:›

definition eqBut where
"eqBut val val' xs x 
  ys y. (ys = xs  y = x)  val ys y = val' ys y"

definition updVal ::
"('varSort,'var,'sTerm)val 
 'var  'sTerm  'varSort 
 ('varSort,'var,'sTerm)val" ("_ '(_ := _')'__" 200)
where
"(val (x := sX)_xs) 
 λ ys y. (if ys = xs  y = x then sX else val ys y)"

definition swapVal ::
"'varSort  'var  'var  ('varSort,'var,'sTerm)val 
 ('varSort,'var,'sTerm)val"
where
"swapVal zs z1 z2 val  λxs x. val xs (x @xs[z1  z2]_zs) "

abbreviation swapVal_abbrev ("_ ^[_  _]'__" 200) where
"val ^[z1  z2]_zs  swapVal zs z1 z2 val"

definition sWlsVal where
"sWlsVal SEM val 
  ys y. sWls SEM (asSort ys) (val ys y)"

(* The last argument is a dummy argument identifying the type 'var --
it may be regarded as a type argument:  *)

definition sWlsValNE ::
"('index,'bindex,'varSort,'sort,'opSym,'sTerm)semDom  'var  bool"
where
"sWlsValNE SEM x   (val :: ('varSort,'var,'sTerm)val). sWlsVal SEM val"

subsubsection ‹Basic facts›

lemma sWlsNE_imp_sWlsAbsNE:
assumes "sWlsNE SEM"
shows "sWlsAbsNE SEM"
unfolding sWlsAbsNE_def proof clarify
  fix xs s
  obtain sY where "sWls SEM s sY"
  using assms unfolding sWlsNE_def by auto
  moreover assume "isInBar (xs,s)"
  ultimately
  have "sWlsAbs SEM (xs,s) (sAbs xs (λsX. if sWls SEM (asSort xs) sX
                                           then sY
                                           else sDummy SEM s))" by simp
  thus "sA. sWlsAbs SEM (xs,s) sA" by blast
qed

lemma sWlsDisj_imp_sWlsAbsDisj:
"sWlsDisj SEM  sWlsNE SEM  sWlsAbsDisj SEM"
by (simp add: sWlsAbsDisj_def sWlsNE_def sWlsDisj_def) 
   (smt prod.inject sAbs.inject sWlsAbs.elims(2))

lemma sWlsNE_imp_sWlsValNE:
"sWlsNE SEM  sWlsValNE SEM x"  
by (auto simp: sWlsNE_def  sWlsValNE_def sWlsVal_def 
 intro!: exI someI_ex[of "(λ sY. sWls SEM (asSort _) sY)"])
 
theorem updVal_simp[simp]:
"(val (x := sX)_xs) ys y = (if ys = xs  y = x then sX else val ys y)"
unfolding updVal_def by simp

theorem updVal_over[simp]:
"((val (x := sX)_xs) (x := sX')_xs) = (val (x := sX')_xs)"
unfolding updVal_def by fastforce

theorem updVal_commute:
assumes "xs  ys  x  y"
shows "((val (x := sX)_xs) (y := sY)_ys) = ((val (y := sY)_ys) (x := sX)_xs)"
using assms unfolding updVal_def by fastforce

theorem updVal_preserves_sWls[simp]:
assumes "sWls SEM (asSort xs) sX" and "sWlsVal SEM val"
shows "sWlsVal SEM (val (x := sX)_xs)"
using assms unfolding sWlsVal_def by auto

lemmas updVal_simps = updVal_simp updVal_over updVal_preserves_sWls

theorem swapVal_ident[simp]: "(val ^[x  x]_xs) = val"
unfolding swapVal_def by auto

theorem swapVal_compose:
"((val ^[x  y]_zs) ^[x'  y']_zs') =
 ((val ^[x' @zs'[x  y]_zs  y' @zs'[x  y]_zs]_zs') ^[x  y]_zs)"
unfolding swapVal_def by (metis sw_compose) 
 
theorem swapVal_commute:
"zs  zs'  {x,y}  {x',y'} = {} 
 ((val ^[x  y]_zs) ^[x'  y']_zs') = ((val ^[x'  y']_zs') ^[x  y]_zs)"
using swapVal_compose[of zs' x' y' zs x y val] by(simp add: sw_def)

lemma swapVal_involutive[simp]: "((val ^[x  y]_zs) ^[x  y]_zs) = val"
unfolding swapVal_def by auto

lemma swapVal_sym: "(val ^[x  y]_zs) = (val ^[y  x]_zs)"
unfolding swapVal_def by(auto simp add: sw_sym)

lemma swapVal_preserves_sWls1:
assumes "sWlsVal SEM val"
shows "sWlsVal SEM (val ^[z1  z2]_zs)"
using assms unfolding sWlsVal_def swapVal_def by simp

theorem swapVal_preserves_sWls[simp]:
"sWlsVal SEM (val ^[z1  z2]_zs) = sWlsVal SEM val"
using swapVal_preserves_sWls1[of _ _ zs z1 z2] by fastforce
 
lemmas swapVal_simps = swapVal_ident swapVal_involutive swapVal_preserves_sWls

lemma updVal_swapVal:
"((val (x := sX)_xs) ^[y1  y2]_ys) =
 ((val ^[y1  y2]_ys) ((x @xs[y1  y2]_ys) := sX)_xs)"
unfolding swapVal_def by fastforce

lemma updVal_preserves_eqBut:
assumes "eqBut val val' ys y"
shows "eqBut (val (x := sX)_xs) (val' (x := sX)_xs) ys y"
using assms unfolding eqBut_def updVal_def by auto

lemma updVal_eqBut_eq:
assumes "eqBut val val' ys y"
shows "(val (y := sY)_ys) = (val' (y := sY)_ys)"
using assms unfolding eqBut_def by fastforce 
   
lemma swapVal_preserves_eqBut:
assumes "eqBut val val' xs x"
shows "eqBut (val ^[z1  z2]_zs) (val' ^[z1  z2]_zs) xs (x @xs[z1  z2]_zs)"
using assms unfolding eqBut_def swapVal_def by force

subsection ‹Interpretation maps›

text‹An interpretation map, of syntax in a semantic domain,
is the usual one w.r.t. valuations.  Here we state its compostionality conditions
(including the ``substitution lemma"), and later we prove the existence of a map
satisfying these conditions.›

subsubsection ‹Definitions›

text ‹Below, prefix ``pr" means ``preserves".›

definition prWls where
"prWls g SEM   s X val.
    wls s X  sWlsVal SEM val
     sWls SEM s (g X val)"

definition prWlsAbs where
"prWlsAbs gA SEM   us s A val.
    wlsAbs (us,s) A  sWlsVal SEM val
     sWlsAbs SEM (us,s) (gA A val)"

definition prWlsAll where
"prWlsAll g gA SEM  prWls g SEM  prWlsAbs gA SEM"

definition prVar where
"prVar g SEM   xs x val.
    sWlsVal SEM val  g (Var xs x) val = val xs x"

definition prAbs where
"prAbs g gA SEM   xs s x X val.
    isInBar (xs,s)  wls s X  sWlsVal SEM val
    
    gA (Abs xs x X) val =
    sAbs xs (λsX. if sWls SEM (asSort xs) sX then g X (val (x := sX)_xs)
                                             else sDummy SEM s)"

definition prOp where
"prOp g gA SEM   delta inp binp val.
    wlsInp delta inp  wlsBinp delta binp  sWlsVal SEM val
    
    g (Op delta inp binp) val =
    sOp SEM delta (lift (λX. g X val) inp)
                  (lift (λA. gA A val) binp)"

definition prCons where
"prCons g gA SEM  prVar g SEM  prAbs g gA SEM  prOp g gA SEM"

definition prFresh where
"prFresh g SEM   ys y s X val val'.
   wls s X  fresh ys y X 
   sWlsVal SEM val  sWlsVal SEM val'  eqBut val val' ys y
    g X val = g X val'"

definition prFreshAbs where
"prFreshAbs gA SEM   ys y us s A val val'.
   wlsAbs (us,s) A  freshAbs ys y A 
   sWlsVal SEM val  sWlsVal SEM val'  eqBut val val' ys y
    gA A val = gA A val'"

definition prFreshAll where
"prFreshAll g gA SEM  prFresh g SEM  prFreshAbs gA SEM"

definition prSwap where
"prSwap g SEM   zs z1 z2 s X val.
   wls s X  sWlsVal SEM val
   
   g (X #[z1  z2]_zs) val =
   g X (val ^[z1  z2]_zs)"

definition prSwapAbs where
"prSwapAbs gA SEM   zs z1 z2 us s A val.
   wlsAbs (us,s) A  sWlsVal SEM val
   
   gA (A $[z1  z2]_zs) val =
   gA A (val ^[z1  z2]_zs)"

definition prSwapAll where
"prSwapAll g gA SEM  prSwap g SEM  prSwapAbs gA SEM"

definition prSubst where
"prSubst g SEM   ys Y y s X val.
    wls (asSort ys) Y  wls s X
     sWlsVal SEM val
    
    g (X #[Y / y]_ys) val =
    g X (val (y := g Y val)_ys)"

definition prSubstAbs where
"prSubstAbs g gA SEM   ys Y y us s A val.
    wls (asSort ys) Y  wlsAbs (us,s) A
     sWlsVal SEM val
    
    gA (A $[Y / y]_ys) val =
    gA A (val (y := g Y val)_ys)"

definition prSubstAll where
"prSubstAll g gA SEM  prSubst g SEM  prSubstAbs g gA SEM"

definition compInt where
"compInt g gA SEM  prWlsAll g gA SEM  prCons g gA SEM 
 prFreshAll g gA SEM  prSwapAll g gA SEM  prSubstAll g gA SEM"

subsubsection ‹Extension of domain preservation to inputs›

lemma prWls_wlsInp:
assumes "wlsInp delta inp" and "prWls g SEM" and "sWlsVal SEM val"
shows "sWlsInp SEM delta (lift (λ X. g X val) inp)"
using assms unfolding sWlsInp_def wlsInp_iff liftAll2_def lift_def prWls_def  
by (auto simp add: option.case_eq_if sameDom_def)

lemma prWlsAbs_wlsBinp:
assumes "wlsBinp delta binp" and "prWlsAbs gA SEM" and "sWlsVal SEM val"
shows "sWlsBinp SEM delta (lift (λ A. gA A val) binp)"
using assms unfolding sWlsBinp_def wlsBinp_iff liftAll2_def lift_def prWlsAbs_def
by (auto simp add: option.case_eq_if sameDom_def)

end (* context FixSyn *)
(***************************************)

subsection ‹The iterative model associated to a semantic domain›

text‹
``asIMOD SEM" stands for ``SEM (regarded) as a model".
%
\footnote{
We use the word ``model" as introduced in the theory ``Models-and-Recursion".
}
%
The associated model is built essentially as follows:
%
\\- Its carrier sets consist of functions from valuations to semantic items.
%
\\- The construct operations (i.e., those corresponding to the syntactic constructs
indicated in the given binding signature) are lifted componentwise from those of the semantic domain
``SEM" (also taking into account the higher-order nature of of the semantic counterparts of abstractions).
%
\\- For a map from valuations to items (terms or abstractions), freshness of a variable ``x"
is defined as being oblivious what the argument valuation returns for ``x".
%
\\- Swapping is defined componentwise, by two iterations of the notion of swapping the
returned value of a function.
%
\\- Substitution of a semantic term ``Y" for a variable ``y" is a semantic term ``X"
is defined to map each valuation ``val" to the application of ``X" to
[``val" updated at ``y" with whatever ``Y" returns for ``val"].

Note that:
%
\\- The construct operations definitions are determined by the desired clauses of the standard
notion of interpreting syntax in a semantic domains.
%
\\- Substitution and freshness are defined having in mind the (again standard) facts of
the interpretation commuting with substitution versus valuation update and the interpretation
being oblivious to the valuation of fresh variables.
›

subsubsection ‹Definition and basic facts›

text‹
The next two types of ``generalized items" are used to build models from semantic domains:
%
\footnote{
Recall that ``generalized items" inhabit models.
}
%
›

type_synonym ('varSort,'var,'sTerm) gTerm = "('varSort,'var,'sTerm)val  'sTerm"

type_synonym ('varSort,'var,'sTerm) gAbs = "('varSort,'var,'sTerm)val  ('varSort,'sTerm)sAbs"

(* *************************************************** *)
context FixSyn
begin

definition asIMOD ::
"('index,'bindex,'varSort,'sort,'opSym,'sTerm)semDom 
 ('index,'bindex,'varSort,'sort,'opSym,'var,
  ('varSort,'var,'sTerm)gTerm,
  ('varSort,'var,'sTerm)gAbs)model"
where
"asIMOD SEM 
 igWls = λs X.  val. (sWlsVal SEM val  X val = undefined) 
                      (sWlsVal SEM val  sWls SEM s (X val)),
  igWlsAbs = λ(xs,s) A.  val. (sWlsVal SEM val  A val = undefined) 
                              (sWlsVal SEM val  sWlsAbs SEM (xs,s) (A val)),
  igVar = λys y. λval. if sWlsVal SEM val then val ys y else undefined,
  igAbs =
  λxs x X. λval. if sWlsVal SEM val
                   then sAbs xs (λsX. if sWls SEM (asSort xs) sX
                                         then X (val (x := sX)_xs)
                                         else sDummy SEM (SOME s. sWls SEM s (X val)))
                   else undefined,
  igOp = λdelta inp binp. λval.
          if sWlsVal SEM val then sOp SEM delta (lift (λX. X val) inp)
                                                (lift (λA. A val) binp)
                             else undefined,
  igFresh =
  λys y X.  val val'. sWlsVal SEM val  sWlsVal SEM val'  eqBut val val' ys y
                        X val = X val',
  igFreshAbs =
  λys y A.  val val'. sWlsVal SEM val  sWlsVal SEM val'  eqBut val val' ys y
                        A val = A val',
  igSwap = λzs z1 z2 X. λval. if sWlsVal SEM val then X (val ^[z1  z2]_zs)
                                                else undefined,
  igSwapAbs = λzs z1 z2 A. λval. if sWlsVal SEM val then A (val ^[z1  z2]_zs)
                                                   else undefined,
  igSubst = λys Y y X. λval. if sWlsVal SEM val then X (val (y := Y val)_ys)
                                                else undefined,
  igSubstAbs = λys Y y A. λval. if sWlsVal SEM val then A (val (y := Y val)_ys)
                                                   else undefined"

text‹Next we state, as usual, the direct definitions of the operators and relations
of associated model, freeing ourselves from
having to go through the ``asIMOD" definition each time we reason about them.›

lemma asIMOD_igWls:
"igWls (asIMOD SEM) s X  
 ( val. (sWlsVal SEM val  X val = undefined) 
         (sWlsVal SEM val  sWls SEM s (X val)))"
unfolding asIMOD_def by simp

lemma asIMOD_igWlsAbs:
"igWlsAbs (asIMOD SEM) (us,s) A  
 ( val. (sWlsVal SEM val  A val = undefined) 
         (sWlsVal SEM val  sWlsAbs SEM (us,s) (A val)))"
unfolding asIMOD_def by simp

lemma asIMOD_igOp:
"igOp (asIMOD SEM) delta inp binp =
(λval. if sWlsVal SEM val then sOp SEM delta (lift (λX. X val) inp)
                                             (lift (λA. A val) binp)
                          else undefined)"
unfolding asIMOD_def by simp

lemma asIMOD_igVar:
"igVar (asIMOD SEM) ys y = (λval. if sWlsVal SEM val then val ys y else undefined)"
unfolding asIMOD_def by simp

lemma asIMOD_igAbs:
"igAbs (asIMOD SEM) xs x X =
(λval. if sWlsVal SEM val then sAbs xs (λsX. if sWls SEM (asSort xs) sX
                                                then X (val (x := sX)_xs)
                                                else sDummy SEM (SOME s. sWls SEM s (X val)))
                          else undefined)"
unfolding asIMOD_def by simp

lemma asIMOD_igAbs2:
fixes SEM :: "('index,'bindex,'varSort,'sort,'opSym,'sTerm)semDom"
assumes *: "sWlsDisj SEM" and **: "igWls (asIMOD SEM) s X"
shows "igAbs (asIMOD SEM) xs x X =
(λval. if sWlsVal SEM val then sAbs xs (λsX. if sWls SEM (asSort xs) sX
                                                then X (val (x := sX)_xs)
                                                else sDummy SEM s)
                          else undefined)"
proof-
  {fix val :: "('varSort,'var,'sTerm)val" assume val: "sWlsVal SEM val"
   hence Xval: "sWls SEM s (X val)"
   using ** unfolding asIMOD_igWls by simp
   hence "(SOME s. sWls SEM s (X val)) = s"
   using Xval * unfolding sWlsDisj_def by auto
  }
  thus ?thesis unfolding asIMOD_igAbs by fastforce
qed

lemma asIMOD_igFresh:
"igFresh (asIMOD SEM) ys y X =
( val val'. sWlsVal SEM val  sWlsVal SEM val'  eqBut val val' ys y
              X val = X val')"
unfolding asIMOD_def by simp

lemma asIMOD_igFreshAbs:
"igFreshAbs (asIMOD SEM) ys y A =
( val val'. sWlsVal SEM val  sWlsVal SEM val'  eqBut val val' ys y
              A val = A val')"
unfolding asIMOD_def by simp

lemma asIMOD_igSwap:
"igSwap (asIMOD SEM) zs z1 z2 X =
(λval. if sWlsVal SEM val then X (val ^[z1  z2]_zs) else undefined)"
unfolding asIMOD_def by simp

lemma asIMOD_igSwapAbs:
"igSwapAbs (asIMOD SEM) zs z1 z2 A =
(λval. if sWlsVal SEM val then A (val ^[z1  z2]_zs) else undefined)"
unfolding asIMOD_def by simp

lemma asIMOD_igSubst:
"igSubst (asIMOD SEM) ys Y y X =
(λval. if sWlsVal SEM val then X (val (y := Y val)_ys) else undefined)"
unfolding asIMOD_def by simp

lemma asIMOD_igSubstAbs:
"igSubstAbs (asIMOD SEM) ys Y y A =
(λval. if sWlsVal SEM val then A (val (y := Y val)_ys) else undefined)"
unfolding asIMOD_def by simp

lemma asIMOD_igWlsInp: 
assumes "sWlsNE SEM"
shows
"igWlsInp (asIMOD SEM) delta inp  
 (( val. liftAll (λX. sWlsVal SEM val  X val = undefined) inp) 
  ( val. sWlsVal SEM val  sWlsInp SEM delta (lift (λX. X val) inp)))"
using assms apply safe
 subgoal by (simp add: asIMOD_igWls liftAll_def liftAll2_def igWlsInp_def 
  sameDom_def split: option.splits) (metis option.distinct(1) option.exhaust)
 subgoal by (simp add: igWlsInp_def asIMOD_igWls liftAll_def liftAll2_def 
  lift_def sWlsInp_def sameDom_def split: option.splits) 
 subgoal by (simp add:igWlsInp_def asIMOD_igWls liftAll_def liftAll2_def 
  lift_def sWlsInp_def sameDom_def split: option.splits) 
  (metis (no_types) option.distinct(1) sWlsNE_imp_sWlsValNE sWlsValNE_def) .

lemma asIMOD_igSwapInp:
"sWlsVal SEM val  
 lift (λX. X val) (igSwapInp (asIMOD SEM) zs z1 z2 inp) =
 lift (λX. X (swapVal zs z1 z2 val)) inp"
by (auto simp: igSwapInp_def asIMOD_igSwap lift_def split: option.splits)

lemma asIMOD_igSubstInp:
"sWlsVal SEM val  
 lift (λX. X val) (igSubstInp (asIMOD SEM) ys Y y inp) =
 lift (λX. X (val (y := Y val)_ys)) inp"
by (auto simp: igSubstInp_def asIMOD_igSubst lift_def split: option.splits)

lemma asIMOD_igWlsBinp: 
assumes "sWlsNE SEM"
shows
"igWlsBinp (asIMOD SEM) delta binp =
 (( val. liftAll (λX. sWlsVal SEM val  X val = undefined) binp) 
  ( val. sWlsVal SEM val  sWlsBinp SEM delta (lift (λX. X val) binp)))"
using assms apply safe
 subgoal by (simp add: asIMOD_igWlsAbs liftAll_def liftAll2_def igWlsBinp_def 
  sameDom_def split: option.splits)
 (metis option.distinct(1) option.exhaust surj_pair)
 subgoal by (simp add: igWlsBinp_def asIMOD_igWlsAbs liftAll_def liftAll2_def 
  lift_def sWlsBinp_def sameDom_def split: option.splits) 
 subgoal by (simp add:igWlsBinp_def asIMOD_igWlsAbs liftAll_def liftAll2_def 
  lift_def sWlsBinp_def sameDom_def split: option.splits) 
  (metis (no_types) old.prod.exhaust option.distinct(1) option.exhaust 
   sWlsNE_imp_sWlsValNE sWlsValNE_def) .

lemma asIMOD_igSwapBinp:
"sWlsVal SEM val  
 lift (λA. A val) (igSwapBinp (asIMOD SEM) zs z1 z2 binp) =
 lift (λA. A (swapVal zs z1 z2 val)) binp"
by (auto simp: igSwapBinp_def asIMOD_igSwapAbs lift_def split: option.splits)

lemma asIMOD_igSubstBinp:
"sWlsVal SEM val  
 lift (λA. A val) (igSubstBinp (asIMOD SEM) ys Y y binp) =
 lift (λA. A (val (y := Y val)_ys)) binp"
by (auto simp: igSubstBinp_def asIMOD_igSubstAbs lift_def split: option.splits)

subsubsection ‹The associated model is well-structured›

text‹That is to say: it is a fresh-swap-subst
and fresh-subst-swap model (hence of course also a fresh-swap and fresh-subst) model.›

text‹Domain disjointness:›

lemma asIMOD_igWlsDisj:
"sWlsNE SEM  sWlsDisj SEM  igWlsDisj (asIMOD SEM)"
using sWlsNE_imp_sWlsValNE 
by (fastforce simp: igWlsDisj_def asIMOD_igWls sWlsValNE_def sWlsDisj_def)

lemma asIMOD_igWlsAbsDisj:
"sWlsNE SEM  sWlsDisj SEM  igWlsAbsDisj (asIMOD SEM)"
using sWlsNE_imp_sWlsValNE sWlsDisj_imp_sWlsAbsDisj
by (fastforce simp: igWlsAbsDisj_def asIMOD_igWlsAbs sWlsAbsDisj_def sWlsValNE_def)

lemma asIMOD_igWlsAllDisj: 
"sWlsNE SEM  sWlsDisj SEM  igWlsAllDisj (asIMOD SEM)"
unfolding igWlsAllDisj_def using asIMOD_igWlsDisj asIMOD_igWlsAbsDisj by auto

text ‹Only ``bound arit" abstraction domains are inhabited:›

lemma asIMOD_igWlsAbsIsInBar:
"sWlsNE SEM  igWlsAbsIsInBar (asIMOD SEM)"
using sWlsNE_imp_sWlsValNE 
by (auto simp: sWlsValNE_def igWlsAbsIsInBar_def asIMOD_igWlsAbs 
         split: option.splits elim: sWlsAbs.elims(2))  

text‹Domain preservation by the operators›

text‹The constructs preserve the domains:›

lemma asIMOD_igVarIPresIGWls: "igVarIPresIGWls (asIMOD SEM)"
unfolding igVarIPresIGWls_def asIMOD_igWls asIMOD_igVar sWlsVal_def by simp

lemma asIMOD_igAbsIPresIGWls:
"sWlsDisj SEM  igAbsIPresIGWls (asIMOD SEM)"
unfolding igAbsIPresIGWls_def asIMOD_igWlsAbs apply clarify
subgoal for _ _ _ _ val
unfolding asIMOD_igAbs2 by (cases "sWlsVal SEM val") (auto simp: asIMOD_igWls) .

lemma asIMOD_igOpIPresIGWls: 
"sOpPrSWls SEM  sWlsNE SEM  igOpIPresIGWls (asIMOD SEM)"
using asIMOD_igWlsInp asIMOD_igWlsBinp 
by (fastforce simp: igOpIPresIGWls_def asIMOD_igWls asIMOD_igOp sOpPrSWls_def)

lemma asIMOD_igConsIPresIGWls: 
"wlsSEM SEM  igConsIPresIGWls (asIMOD SEM)"
unfolding igConsIPresIGWls_def wlsSEM_def
using asIMOD_igVarIPresIGWls asIMOD_igAbsIPresIGWls asIMOD_igOpIPresIGWls by auto

text‹Swap preserves the domains:›

lemma asIMOD_igSwapIPresIGWls: "igSwapIPresIGWls (asIMOD SEM)"
unfolding igSwapIPresIGWls_def asIMOD_igSwap asIMOD_igWls by auto

lemma asIMOD_igSwapAbsIPresIGWlsAbs: "igSwapAbsIPresIGWlsAbs (asIMOD SEM)"
unfolding igSwapAbsIPresIGWlsAbs_def asIMOD_igSwapAbs asIMOD_igWlsAbs by auto

lemma asIMOD_igSwapAllIPresIGWlsAll: "igSwapAllIPresIGWlsAll (asIMOD SEM)"
unfolding igSwapAllIPresIGWlsAll_def
using asIMOD_igSwapIPresIGWls asIMOD_igSwapAbsIPresIGWlsAbs by auto

text ‹Subst preserves the domains:›

lemma asIMOD_igSubstIPresIGWls: "igSubstIPresIGWls (asIMOD SEM)"
unfolding igSubstIPresIGWls_def asIMOD_igSubst asIMOD_igWls by simp

lemma asIMOD_igSubstAbsIPresIGWlsAbs: "igSubstAbsIPresIGWlsAbs (asIMOD SEM)"
unfolding igSubstAbsIPresIGWlsAbs_def asIMOD_igSubstAbs asIMOD_igWls asIMOD_igWlsAbs by simp

lemma asIMOD_igSubstAllIPresIGWlsAll: "igSubstAllIPresIGWlsAll (asIMOD SEM)"
unfolding igSubstAllIPresIGWlsAll_def
using asIMOD_igSubstIPresIGWls asIMOD_igSubstAbsIPresIGWlsAbs by auto

text ‹The clauses for fresh hold:›

lemma asIMOD_igFreshIGVar: "igFreshIGVar (asIMOD SEM)"
unfolding igFreshIGVar_def asIMOD_igFresh asIMOD_igVar eqBut_def by force

lemma asIMOD_igFreshIGAbs1:
"sWlsDisj SEM  igFreshIGAbs1 (asIMOD SEM)"
by(fastforce simp: igFreshIGAbs1_def asIMOD_igFresh asIMOD_igFreshAbs asIMOD_igAbs2 updVal_eqBut_eq)
 
lemma asIMOD_igFreshIGAbs2:
"sWlsDisj SEM  igFreshIGAbs2 (asIMOD SEM)"
by(fastforce simp: igFreshIGAbs2_def asIMOD_igFresh asIMOD_igFreshAbs asIMOD_igAbs2  updVal_preserves_eqBut)

lemma asIMOD_igFreshIGOp:
fixes SEM :: "('index,'bindex,'varSort,'sort,'opSym,'sTerm)semDom"
shows "igFreshIGOp (asIMOD SEM)"
unfolding igFreshIGOp_def proof clarify
  fix ys y delta and inp :: "('index, ('varSort,'var,'sTerm)gTerm)input"
  and binp :: "('bindex, ('varSort,'var,'sTerm)gAbs)input"
  assume inp_fresh: "igFreshInp (asIMOD SEM) ys y inp"
                    "igFreshBinp (asIMOD SEM) ys y binp"
  show "igFresh (asIMOD SEM) ys y (igOp (asIMOD SEM) delta inp binp)"
  unfolding asIMOD_igFresh asIMOD_igOp proof safe
    fix val val'
    let ?sinp = "lift (λX. X val) inp" let ?sinp' = "lift (λX. X val') inp"
    let ?sbinp = "lift (λA. A val) binp" let ?sbinp' = "lift (λA. A val') binp"
    assume wls: "sWlsVal SEM val" "sWlsVal SEM val'" and "eqBut val val' ys y"
    hence "?sinp = ?sinp'  ?sbinp = ?sbinp'"
    using inp_fresh
    by (auto simp: lift_def igFreshInp_def igFreshBinp_def errMOD_def liftAll_def 
    asIMOD_igFresh asIMOD_igFreshAbs split: option.splits) 
    then show "(if sWlsVal SEM val then sOp SEM delta (lift (λX. X val) inp) (lift (λA. A val) binp)
           else undefined) =
          (if sWlsVal SEM val' then sOp SEM delta (lift (λX. X val') inp) (lift (λA. A val') binp)
           else undefined)" using wls by auto 
  qed
qed 

lemma asIMOD_igFreshCls:
assumes "sWlsDisj SEM"
shows "igFreshCls (asIMOD SEM)"
using assms unfolding igFreshCls_def
using asIMOD_igFreshIGVar asIMOD_igFreshIGAbs1 asIMOD_igFreshIGAbs2 asIMOD_igFreshIGOp by auto

text ‹The clauses for swap hold:›

lemma asIMOD_igSwapIGVar: "igSwapIGVar (asIMOD SEM)"
unfolding igSwapIGVar_def apply clarsimp apply(rule ext)
unfolding asIMOD_igSwap asIMOD_igVar apply clarsimp
unfolding swapVal_def by simp

lemma asIMOD_igSwapIGAbs: "igSwapIGAbs (asIMOD SEM)"
by (fastforce simp: igSwapIGAbs_def asIMOD_igSwap asIMOD_igSwapAbs asIMOD_igAbs updVal_swapVal)
 
lemma asIMOD_igSwapIGOp: "igSwapIGOp (asIMOD SEM)"
by (auto simp: igSwapIGOp_def asIMOD_igSwap asIMOD_igOp asIMOD_igSwapInp asIMOD_igSwapBinp)
 
lemma asIMOD_igSwapCls: "igSwapCls (asIMOD SEM)"
unfolding igSwapCls_def using asIMOD_igSwapIGVar asIMOD_igSwapIGAbs asIMOD_igSwapIGOp by auto

text‹The clauses for subst hold:›

lemma asIMOD_igSubstIGVar1: "igSubstIGVar1 (asIMOD SEM)"
by (auto simp: igSubstIGVar1_def asIMOD_igSubst asIMOD_igVar asIMOD_igWls)

lemma asIMOD_igSubstIGVar2: "igSubstIGVar2 (asIMOD SEM)"
by (fastforce simp: igSubstIGVar2_def asIMOD_igSubst asIMOD_igVar asIMOD_igWls)

lemma asIMOD_igSubstIGAbs: "igSubstIGAbs (asIMOD SEM)"
unfolding igSubstIGAbs_def proof(clarify, rule ext)
  fix ys y Y xs x s X val
  assume Y: "igWls (asIMOD SEM) (asSort ys) Y"
  and X: "igWls (asIMOD SEM) s X" and x_diff_y: "xs  ys  x  y"
  and x_fresh_Y: "igFresh (asIMOD SEM) xs x Y"
  show "igSubstAbs (asIMOD SEM) ys Y y (igAbs (asIMOD SEM) xs x X) val =
        igAbs (asIMOD SEM) xs x (igSubst (asIMOD SEM) ys Y y X) val"
  proof(cases "sWlsVal SEM val")
    case False
    thus ?thesis unfolding asIMOD_igSubst asIMOD_igSubstAbs asIMOD_igAbs by simp
  next
    case True  
    hence Yval: "sWls SEM (asSort ys) (Y val)"
    using Y unfolding asIMOD_igWls by simp
    {fix sX assume sX: "sWls SEM (asSort xs) sX"
     let ?val_x = "val (x := sX)_xs"
     have "sWlsVal SEM ?val_x" using True sX by simp
     moreover have "eqBut ?val_x val xs x"
     unfolding eqBut_def updVal_def by simp
     ultimately have 1: "Y ?val_x = Y val"
     using True x_fresh_Y unfolding asIMOD_igFresh by simp
     let ?Left = "X ((val (y := Y val)_ys) (x := sX)_xs)"
     let ?Riight = "X (?val_x (y := Y ?val_x)_ys)"
     have "?Left = X (?val_x (y := Y val)_ys)"
     using x_diff_y by(auto simp add: updVal_commute)
     also have " = ?Riight" using 1 by simp
     finally have "?Left = ?Riight" . 
    }  
    thus ?thesis using True Yval by(auto simp: asIMOD_igSubst asIMOD_igSubstAbs asIMOD_igAbs) 
  qed
qed

lemma asIMOD_igSubstIGOp: "igSubstIGOp (asIMOD SEM)" 
unfolding igSubstIGOp_def proof(clarify,rule ext)
  fix ys y Y delta inp binp val
  assume Y: "igWls (asIMOD SEM) (asSort ys) Y"
  and inp: "igWlsInp (asIMOD SEM) delta inp"
  and binp: "igWlsBinp (asIMOD SEM) delta binp"
  define inpsb binpsb where
  inpsb_def: "inpsb  igSubstInp (asIMOD SEM) ys Y y inp"
             "binpsb  igSubstBinp (asIMOD SEM) ys Y y binp"
  note inpsb_rev = inpsb_def[symmetric] 
  let ?sinpsb = "lift (λX. X (val (y := Y val)_ys)) inp"
  let ?sbinpsb = "lift (λA. A (val (y := Y val)_ys)) binp"
  show "igSubst (asIMOD SEM) ys Y y (igOp (asIMOD SEM) delta inp binp) val =
        igOp (asIMOD SEM) delta (igSubstInp (asIMOD SEM) ys Y y inp)
                              (igSubstBinp (asIMOD SEM) ys Y y binp) val"
  unfolding inpsb_rev unfolding asIMOD_igSubst asIMOD_igOp unfolding inpsb_def 
  apply(simp add: asIMOD_igSubstInp asIMOD_igSubstBinp)
  using Y unfolding asIMOD_def by auto
qed

lemma asIMOD_igSubstCls: "igSubstCls (asIMOD SEM)"
unfolding igSubstCls_def
using asIMOD_igSubstIGVar1 asIMOD_igSubstIGVar2 asIMOD_igSubstIGAbs asIMOD_igSubstIGOp by auto

text ‹The fresh-swap-based congruence clause holds:›

lemma updVal_swapVal_eqBut: "eqBut (val (x := sX)_xs) ((val (y := sX)_xs) ^[y  x]_xs) xs y"
by (simp add: updVal_def swapVal_def eqBut_def sw_def) 

lemma asIMOD_igAbsCongS: "sWlsDisj SEM  igAbsCongS (asIMOD SEM)"
unfolding igAbsCongS_def asIMOD_igFresh asIMOD_igSwap asIMOD_igAbs2 
apply safe apply (simp add: asIMOD_igAbs2) 
by (rule ext) (metis (hide_lams) updVal_swapVal_eqBut swapVal_preserves_sWls updVal_preserves_sWls) 

 

text ‹The abstraction-renaming clause holds:›

lemma asIMOD_igAbs3:
assumes "sWlsDisj SEM" and "igWls (asIMOD SEM) s X"
shows
"igAbs (asIMOD SEM) xs y (igSubst (asIMOD SEM) xs (igVar (asIMOD SEM) xs y) x X) =
 (λval. if sWlsVal SEM val
            then sAbs xs (λsX. if sWls SEM (asSort xs) sX
                                 then (igSubst (asIMOD SEM) xs (igVar (asIMOD SEM) xs y) x X) (val (y := sX)_xs)
                                 else sDummy SEM s)
            else undefined)"
using assms asIMOD_igVarIPresIGWls asIMOD_igSubstIPresIGWls
unfolding igVarIPresIGWls_def igSubstIPresIGWls_def
by (fastforce intro!: asIMOD_igAbs2)

lemma asIMOD_igAbsRen:
"sWlsDisj SEM  igAbsRen (asIMOD SEM)"
unfolding igAbsRen_def asIMOD_igFresh asIMOD_igSwap apply safe
by (simp add: asIMOD_igAbs2 asIMOD_igAbs3)  
   (auto intro!: ext simp: asIMOD_igAbs2 asIMOD_igAbs3 eqBut_def asIMOD_igSubst asIMOD_igVar)

text ‹The associated model forms well-structured models of all 4 kinds:›

lemma asIMOD_wlsFSw:
assumes "wlsSEM SEM"
shows "iwlsFSw (asIMOD SEM)"
using assms unfolding wlsSEM_def iwlsFSw_def
using assms asIMOD_igWlsAllDisj asIMOD_igWlsAbsIsInBar 
asIMOD_igConsIPresIGWls asIMOD_igSwapAllIPresIGWlsAll 
asIMOD_igFreshCls asIMOD_igSwapCls asIMOD_igAbsCongS 
by auto

lemma asIMOD_wlsFSb:
assumes "wlsSEM SEM"
shows "iwlsFSb (asIMOD SEM)"
using assms unfolding wlsSEM_def iwlsFSb_def
using assms asIMOD_igWlsAllDisj asIMOD_igWlsAbsIsInBar 
asIMOD_igConsIPresIGWls[of SEM] asIMOD_igSubstAllIPresIGWlsAll 
asIMOD_igFreshCls  asIMOD_igSubstCls asIMOD_igAbsRen 
by auto

lemma asIMOD_wlsFSwSb: "wlsSEM SEM  iwlsFSwSb (asIMOD SEM)"
unfolding iwlsFSwSb_def
using asIMOD_wlsFSw asIMOD_igSubstAllIPresIGWlsAll asIMOD_igSubstCls by auto

lemma asIMOD_wlsFSbSw: "wlsSEM SEM  iwlsFSbSw (asIMOD SEM)"
unfolding iwlsFSbSw_def
using asIMOD_wlsFSb asIMOD_igSwapAllIPresIGWlsAll asIMOD_igSwapCls by auto

subsection ‹The semantic interpretation›

text‹The well-definedness of the semantic interpretation, as well
as its associated substitution lemma and non-dependence of fresh variables,
are the end products of this theory.

Note that in order to establish these results either fresh-subst-swap or
fresh-swap-subst aligebras would do the job, and, moreover, if we did not care
about swapping, fresh-subst aligebras would do the job.  Therefore, our
exhaustive study of the model from previous section had a deigree of redundancy w.r.t. to our main
igoal -- we pursued it however in order to better illustrate the rich structure laying under
the apparent paucity of the notion of a semantic domain.  Next, we choose to employ
fresh-subst-swap aligebras to establish the required results. (Recall however that either aligebraic route
we take, the initial morphism turns out to be the same function.)›

definition semInt where "semInt SEM  iter (asIMOD SEM)"

definition semIntAbs where "semIntAbs SEM  iterAbs (asIMOD SEM)"

lemma semIntAll_termFSwSbImorph:
"wlsSEM SEM 
 termFSwSbImorph (semInt SEM) (semIntAbs SEM) (asIMOD SEM)"
unfolding semInt_def semInt_def semIntAbs_def
using asIMOD_wlsFSbSw iwlsFSbSw_iterAll_termFSwSbImorph by auto

lemma semInt_prWls:
"wlsSEM SEM  prWls (semInt SEM) SEM"
unfolding prWls_def using semIntAll_termFSwSbImorph
unfolding termFSwSbImorph_def termFSwImorph_def ipresWlsAll_def ipresWls_def asIMOD_igWls by auto

lemma semIntAbs_prWlsAbs:
"wlsSEM SEM  prWlsAbs (semIntAbs SEM) SEM"
unfolding prWlsAbs_def using semIntAll_termFSwSbImorph
unfolding termFSwSbImorph_def termFSwImorph_def ipresWlsAll_def ipresWlsAbs_def asIMOD_igWlsAbs by blast

lemma semIntAll_prWlsAll:
"wlsSEM SEM  prWlsAll (semInt SEM) (semIntAbs SEM) SEM"
unfolding prWlsAll_def by(simp add: semInt_prWls semIntAbs_prWlsAbs)

lemma semInt_prVar:
"wlsSEM SEM  prVar (semInt SEM) SEM"
using semIntAll_termFSwSbImorph
unfolding prVar_def termFSwSbImorph_def termFSwImorph_def ipresCons_def ipresVar_def asIMOD_igVar 
by fastforce

lemma semIntAll_prAbs:
fixes SEM :: "('index,'bindex,'varSort,'sort,'opSym,'sTerm)semDom"
assumes "wlsSEM SEM"
shows "prAbs (semInt SEM) (semIntAbs SEM) SEM"
proof-
  {fix xs s x X and val :: "('varSort,'var,'sTerm)val"
   assume xs_s: "isInBar (xs,s)" and X: "wls s X"
   and val: "sWlsVal SEM val"
   let ?L = "semIntAbs SEM (Abs xs x X)"
   let ?R = "λ val. sAbs xs (λsX. if sWls SEM (asSort xs) sX
                              then semInt SEM X (val (x := sX)_xs)
                              else sDummy SEM s)"
   have "?L = igAbs (asIMOD SEM) xs x (semInt SEM X)"
   using xs_s X assms semIntAll_termFSwSbImorph[of SEM]
   unfolding termFSwSbImorph_def termFSwImorph_def ipresCons_def ipresAbs_def by auto
   moreover
   {have "prWls (semInt SEM) SEM" using assms semInt_prWls by auto
    hence 1: "sWls SEM s (semInt SEM X val)"
    using val X unfolding prWls_def by simp
    hence "(SOME s. sWls SEM s (semInt SEM X val)) = s"
    using 1 assms unfolding wlsSEM_def sWlsDisj_def by auto
    hence "igAbs (asIMOD SEM) xs x (semInt SEM X) val = ?R val"
    unfolding asIMOD_igAbs using val by fastforce
   }
   ultimately have "?L val = ?R val" by simp
  }
  thus ?thesis unfolding prAbs_def by auto
qed

lemma semIntAll_prOp:
assumes "wlsSEM SEM"
shows "prOp (semInt SEM) (semIntAbs SEM) SEM"
using assms semIntAll_termFSwSbImorph
unfolding prOp_def termFSwSbImorph_def termFSwImorph_def ipresCons_def ipresOp_def
asIMOD_igOp lift_comp comp_def by fastforce

lemma semIntAll_prCons:
assumes "wlsSEM SEM"
shows "prCons (semInt SEM) (semIntAbs SEM) SEM"
using assms unfolding prCons_def by(simp add: semInt_prVar semIntAll_prAbs semIntAll_prOp)

lemma semInt_prFresh:
assumes "wlsSEM SEM"
shows "prFresh (semInt SEM) SEM"
using assms semIntAll_termFSwSbImorph
unfolding prFresh_def termFSwSbImorph_def termFSwImorph_def ipresFreshAll_def ipresFresh_def
asIMOD_igFresh by fastforce

lemma semIntAbs_prFreshAbs:
assumes "wlsSEM SEM"
shows "prFreshAbs (semIntAbs SEM) SEM"
using assms semIntAll_termFSwSbImorph
unfolding prFreshAbs_def termFSwSbImorph_def termFSwImorph_def ipresFreshAll_def ipresFreshAbs_def
asIMOD_igFreshAbs by fastforce

lemma semIntAll_prFreshAll:
assumes "wlsSEM SEM"
shows "prFreshAll (semInt SEM) (semIntAbs SEM) SEM"
using assms unfolding prFreshAll_def by(simp add: semInt_prFresh semIntAbs_prFreshAbs)

lemma semInt_prSwap:
assumes "wlsSEM SEM"
shows "prSwap (semInt SEM) SEM"
using assms semIntAll_termFSwSbImorph
unfolding prSwap_def termFSwSbImorph_def termFSwImorph_def ipresSwapAll_def ipresSwap_def
asIMOD_igSwap by fastforce

lemma semIntAbs_prSwapAbs:
assumes "wlsSEM SEM"
shows "prSwapAbs (semIntAbs SEM) SEM"
using assms semIntAll_termFSwSbImorph
unfolding prSwapAbs_def termFSwSbImorph_def termFSwImorph_def ipresSwapAll_def ipresSwapAbs_def
asIMOD_igSwapAbs by fastforce

lemma semIntAll_prSwapAll:
assumes "wlsSEM SEM"
shows "prSwapAll (semInt SEM) (semIntAbs SEM) SEM"
using assms unfolding prSwapAll_def by(simp add: semInt_prSwap semIntAbs_prSwapAbs)

lemma semInt_prSubst:
assumes "wlsSEM SEM"
shows "prSubst (semInt SEM) SEM"
using assms semIntAll_termFSwSbImorph
unfolding prSubst_def termFSwSbImorph_def termFSwImorph_def ipresSubstAll_def ipresSubst_def
asIMOD_igSubst by fastforce

lemma semIntAbs_prSubstAbs:
assumes "wlsSEM SEM"
shows "prSubstAbs (semInt SEM) (semIntAbs SEM) SEM"
using assms semIntAll_termFSwSbImorph
unfolding prSubstAbs_def termFSwSbImorph_def termFSwImorph_def ipresSubstAll_def ipresSubstAbs_def
asIMOD_igSubstAbs by fastforce

lemma semIntAll_prSubstAll:
assumes "wlsSEM SEM"
shows "prSubstAll (semInt SEM) (semIntAbs SEM) SEM"
using assms unfolding prSubstAll_def by(simp add: semInt_prSubst semIntAbs_prSubstAbs)

theorem semIntAll_compInt:
assumes "wlsSEM SEM"
shows "compInt (semInt SEM) (semIntAbs SEM) SEM"
using assms unfolding compInt_def
by(simp add: semIntAll_prWlsAll semIntAll_prCons
semIntAll_prFreshAll semIntAll_prSwapAll semIntAll_prSubstAll)

lemmas semDom_simps = updVal_simps swapVal_simps

end (* context FixSyn *)

end

Theory Recursion

section ‹General Recursion›

theory Recursion imports Iteration 
begin

text‹The initiality theorems from the previous section support iteration principles.
Next we extend the results to general recursion.  The difference between
general recursion and iteration is that the former also considers
the (source) ``items" (terms and abstractions), and not only the
(target) generalized items, appear in the recursive clauses.

(Here is an example illustrating the above difference for the standard case
of natural numbers:
\\- Given a number n, the operator ``add-n" can be defined by iteration:
\\--- ``add-n 0 = n",
\\--- ``add-n (Suc m) = Suc (add-n m)".

Notice that, in right-hand side of the recursive clause, ``m" is not used ``directly", but only
via ``add-n" -- this makes the definition iterative. By contrast, the following
definition of predecessor is trivial form of recursion (namely, case analysis),
but is {\em not} iteration:
\\--- ``pred 0 = 0",
\\--- ``pred (Suc n) = n".
)

We achieve our desired extension by augmenting the notion of model
and then essentially inferring recursion (as customary)
from
[iteration having as target the product between the term model and the original model].

As a matter of notation: remember we are using for generalized items
the same meta-variables as for ``items" (terms and abstractions).
But now the model operators will take both items and generalized items.
We shall prime the meta-variables for items (as in X', A', etc).
›

subsection ‹Raw models›

record ('index,'bindex,'varSort,'sort,'opSym,'var,'gTerm,'gAbs)model =
  gWls :: "'sort  'gTerm  bool"
  gWlsAbs :: "'varSort × 'sort  'gAbs  bool"
  (*  *)
  gVar :: "'varSort  'var  'gTerm"
  gAbs ::
  "'varSort  'var 
   ('index,'bindex,'varSort,'var,'opSym)term  'gTerm 
   'gAbs"
  gOp ::
  "'opSym 
   ('index,('index,'bindex,'varSort,'var,'opSym)term)input  ('index,'gTerm)input 
   ('bindex,('index,'bindex,'varSort,'var,'opSym)abs)input  ('bindex,'gAbs)input 
   'gTerm"
  (*  *)
  gFresh ::
  "'varSort  'var  ('index,'bindex,'varSort,'var,'opSym)term  'gTerm  bool"
  gFreshAbs ::
  "'varSort  'var  ('index,'bindex,'varSort,'var,'opSym)abs  'gAbs  bool"
  (*  *)
  gSwap ::
  "'varSort  'var  'var 
   ('index,'bindex,'varSort,'var,'opSym)term  'gTerm 
   'gTerm"
  gSwapAbs ::
  "'varSort  'var  'var 
   ('index,'bindex,'varSort,'var,'opSym)abs  'gAbs 
   'gAbs"
  (*   *)
  gSubst ::
  "'varSort 
   ('index,'bindex,'varSort,'var,'opSym)term  'gTerm 
   'var 
   ('index,'bindex,'varSort,'var,'opSym)term  'gTerm 
   'gTerm"
  gSubstAbs ::
  "'varSort 
   ('index,'bindex,'varSort,'var,'opSym)term  'gTerm 
   'var 
   ('index,'bindex,'varSort,'var,'opSym)abs  'gAbs 
   'gAbs"

subsection ‹Well-sorted models of various kinds›

text‹Lifting the model operations to inputs›

definition gFreshInp where
"gFreshInp MOD ys y inp' inp  liftAll2 (gFresh MOD ys y) inp' inp"

definition gFreshBinp where
"gFreshBinp MOD ys y binp' binp  liftAll2 (gFreshAbs MOD ys y) binp' binp"

definition gSwapInp where
"gSwapInp MOD zs z1 z2 inp' inp  lift2 (gSwap MOD zs z1 z2) inp' inp"

definition gSwapBinp where
"gSwapBinp MOD zs z1 z2 binp' binp  lift2 (gSwapAbs MOD zs z1 z2) binp' binp"

definition gSubstInp where
"gSubstInp MOD ys Y' Y y inp' inp  lift2 (gSubst MOD ys Y' Y y) inp' inp"

definition gSubstBinp where
"gSubstBinp MOD ys Y' Y y binp' binp  lift2 (gSubstAbs MOD ys Y' Y y) binp' binp"

(* *************************************************** *)
context FixSyn
begin

definition gWlsInp where
"gWlsInp MOD delta inp 
 wlsOpS delta  sameDom (arOf delta) inp  liftAll2 (gWls MOD) (arOf delta) inp"

lemmas gWlsInp_defs = gWlsInp_def sameDom_def liftAll2_def

definition gWlsBinp where
"gWlsBinp MOD delta binp 
 wlsOpS delta  sameDom (barOf delta) binp  liftAll2 (gWlsAbs MOD) (barOf delta) binp"

lemmas gWlsBinp_defs = gWlsBinp_def sameDom_def liftAll2_def

text‹Basic properties of the lifted model operations›

text‹. for free inputs:›

lemma sameDom_swapInp_gSwapInp[simp]:
assumes "wlsInp delta inp'" and "gWlsInp MOD delta inp"
shows "sameDom (swapInp zs z1 z2 inp') (gSwapInp MOD zs z1 z2 inp' inp)"
using assms by(simp add: wlsInp_iff gWlsInp_def swapInp_def gSwapInp_def
liftAll2_def lift_def lift2_def sameDom_def split: option.splits)

lemma sameDom_substInp_gSubstInp[simp]:
assumes "wlsInp delta inp'" and "gWlsInp MOD delta inp"
shows "sameDom (substInp ys Y' y inp') (gSubstInp MOD ys Y' Y y inp' inp)"
using assms by(simp add: wlsInp_iff gWlsInp_def substInp_def2 gSubstInp_def
liftAll2_def lift_def lift2_def sameDom_def split: option.splits)

text‹. for bound inputs:›

lemma sameDom_swapBinp_gSwapBinp[simp]:
assumes "wlsBinp delta binp'" and "gWlsBinp MOD delta binp"
shows "sameDom (swapBinp zs z1 z2 binp') (gSwapBinp MOD zs z1 z2 binp' binp)"
using assms by(simp add: wlsBinp_iff gWlsBinp_def swapBinp_def gSwapBinp_def
liftAll2_def lift_def lift2_def sameDom_def split: option.splits)

lemma sameDom_substBinp_gSubstBinp[simp]:
assumes "wlsBinp delta binp'" and "gWlsBinp MOD delta binp"
shows "sameDom (substBinp ys Y' y binp') (gSubstBinp MOD ys Y' Y y binp' binp)"
using assms by(simp add: wlsBinp_iff gWlsBinp_def substBinp_def2 gSubstBinp_def
liftAll2_def lift_def lift2_def sameDom_def split: option.splits)

lemmas sameDom_gInput_simps =
sameDom_swapInp_gSwapInp sameDom_substInp_gSubstInp
sameDom_swapBinp_gSwapBinp sameDom_substBinp_gSubstBinp

text‹Domain disjointness:›

definition gWlsDisj where
"gWlsDisj MOD   s s' X. gWls MOD s X  gWls MOD s' X  s = s'"

definition gWlsAbsDisj where
"gWlsAbsDisj MOD   xs s xs' s' A.
    isInBar (xs,s)  isInBar (xs',s') 
    gWlsAbs MOD (xs,s) A  gWlsAbs MOD (xs',s') A
     xs = xs'  s = s'"

definition gWlsAllDisj where
"gWlsAllDisj MOD  gWlsDisj MOD  gWlsAbsDisj MOD"

lemmas gWlsAllDisj_defs =
gWlsAllDisj_def gWlsDisj_def gWlsAbsDisj_def

text ‹Abstraction domains inhabited only within bound arities:›

definition gWlsAbsIsInBar where
"gWlsAbsIsInBar MOD   us s A. gWlsAbs MOD (us,s) A  isInBar (us,s)"

text‹Domain preservation by the operators›

text‹The constructs preserve the domains:›

definition gVarPresGWls where
"gVarPresGWls MOD   xs x. gWls MOD (asSort xs) (gVar MOD xs x)"

definition gAbsPresGWls where
"gAbsPresGWls MOD   xs s x X' X.
   isInBar (xs,s)  wls s X'  gWls MOD s X 
   gWlsAbs MOD (xs,s) (gAbs MOD xs x X' X)"

definition gOpPresGWls where
"gOpPresGWls MOD   delta inp' inp binp' binp.
   wlsInp delta inp'  gWlsInp MOD delta inp  wlsBinp delta binp'  gWlsBinp MOD delta binp
    gWls MOD (stOf delta) (gOp MOD delta inp' inp binp' binp)"

definition gConsPresGWls where
"gConsPresGWls MOD  gVarPresGWls MOD  gAbsPresGWls MOD  gOpPresGWls MOD"

lemmas gConsPresGWls_defs = gConsPresGWls_def
gVarPresGWls_def gAbsPresGWls_def gOpPresGWls_def

text‹``swap" preserves the domains:›

definition gSwapPresGWls where
"gSwapPresGWls MOD   zs z1 z2 s X' X.
   wls s X'  gWls MOD s X 
   gWls MOD s (gSwap MOD zs z1 z2 X' X)"

definition gSwapAbsPresGWlsAbs where
"gSwapAbsPresGWlsAbs MOD   zs z1 z2 us s A' A.
   isInBar (us,s)  wlsAbs (us,s) A'  gWlsAbs MOD (us,s) A 
   gWlsAbs MOD (us,s) (gSwapAbs MOD zs z1 z2 A' A)"

definition gSwapAllPresGWlsAll where
"gSwapAllPresGWlsAll MOD  gSwapPresGWls MOD  gSwapAbsPresGWlsAbs MOD"

lemmas gSwapAllPresGWlsAll_defs = 
gSwapAllPresGWlsAll_def gSwapPresGWls_def gSwapAbsPresGWlsAbs_def

text‹``subst" preserves the domains:›

definition gSubstPresGWls where
"gSubstPresGWls MOD   ys Y' Y y s X' X.
   wls (asSort ys) Y'  gWls MOD (asSort ys) Y  wls s X'  gWls MOD s X 
   gWls MOD s (gSubst MOD ys Y' Y y X' X)"

definition gSubstAbsPresGWlsAbs where
"gSubstAbsPresGWlsAbs MOD   ys Y' Y y us s A' A.
   isInBar (us,s) 
   wls (asSort ys) Y'  gWls MOD (asSort ys) Y  wlsAbs (us,s) A'  gWlsAbs MOD (us,s) A 
   gWlsAbs MOD (us,s) (gSubstAbs MOD ys Y' Y y A' A)"

definition gSubstAllPresGWlsAll where
"gSubstAllPresGWlsAll MOD  gSubstPresGWls MOD  gSubstAbsPresGWlsAbs MOD"

lemmas gSubstAllPresGWlsAll_defs = 
gSubstAllPresGWlsAll_def gSubstPresGWls_def gSubstAbsPresGWlsAbs_def

text‹Clauses for fresh:›

definition gFreshGVar where
"gFreshGVar MOD   ys y xs x.
   (ys  xs  y  x) 
   gFresh MOD ys y (Var xs x) (gVar MOD xs x)"

definition gFreshGAbs1 where
"gFreshGAbs1 MOD   ys y s X' X.
   isInBar (ys,s)  wls s X'  gWls MOD s X 
   gFreshAbs MOD ys y (Abs ys y X') (gAbs MOD ys y X' X)"

definition gFreshGAbs2 where
"gFreshGAbs2 MOD   ys y xs x s X' X.
   isInBar (xs,s)  wls s X'  gWls MOD s X 
   fresh ys y X'  gFresh MOD ys y X' X 
   gFreshAbs MOD ys y (Abs xs x X') (gAbs MOD xs x X' X)"

definition gFreshGOp where
"gFreshGOp MOD   ys y delta inp' inp binp' binp.
   wlsInp delta inp'  gWlsInp MOD delta inp  wlsBinp delta binp'  gWlsBinp MOD delta binp 
   freshInp ys y inp'  gFreshInp MOD ys y inp' inp 
   freshBinp ys y binp'  gFreshBinp MOD ys y binp' binp 
   gFresh MOD ys y (Op delta inp' binp') (gOp MOD delta inp' inp binp' binp)"

definition gFreshCls where
"gFreshCls MOD  gFreshGVar MOD  gFreshGAbs1 MOD  gFreshGAbs2 MOD  gFreshGOp MOD"

lemmas gFreshCls_defs = gFreshCls_def
gFreshGVar_def gFreshGAbs1_def gFreshGAbs2_def gFreshGOp_def

(* Clauses for swap: fully-conditional versions and less-conditional,
stronger versions (suffix ``STR") *)

definition gSwapGVar where
"gSwapGVar MOD   zs z1 z2 xs x.
   gSwap MOD zs z1 z2 (Var xs x) (gVar MOD xs x) =
   gVar MOD xs (x @xs[z1  z2]_zs)"

definition gSwapGAbs where
"gSwapGAbs MOD   zs z1 z2 xs x s X' X.
   isInBar (xs,s)  wls s X'  gWls MOD s X 
   gSwapAbs MOD zs z1 z2 (Abs xs x X') (gAbs MOD xs x X' X) =
   gAbs MOD xs (x @xs[z1  z2]_zs) (X' #[z1  z2]_zs) (gSwap MOD zs z1 z2 X' X)"

definition gSwapGOp where
"gSwapGOp MOD   zs z1 z2 delta inp' inp binp' binp.
   wlsInp delta inp'  gWlsInp MOD delta inp  wlsBinp delta binp'  gWlsBinp MOD delta binp 
   gSwap MOD zs z1 z2 (Op delta inp' binp') (gOp MOD delta inp' inp binp' binp) =
   gOp MOD delta
     (inp' %[z1  z2]_zs) (gSwapInp MOD zs z1 z2 inp' inp)
     (binp' %%[z1  z2]_zs) (gSwapBinp MOD zs z1 z2 binp' binp)"

definition gSwapCls where
"gSwapCls MOD  gSwapGVar MOD  gSwapGAbs MOD  gSwapGOp MOD"

lemmas gSwapCls_defs = gSwapCls_def
gSwapGVar_def gSwapGAbs_def gSwapGOp_def

(* Clauses for subst: *)

definition gSubstGVar1 where
"gSubstGVar1 MOD   ys y Y' Y xs x.
   wls (asSort ys) Y'  gWls MOD (asSort ys) Y 
   (ys  xs  y  x) 
   gSubst MOD ys Y' Y y (Var xs x) (gVar MOD xs x) =
   gVar MOD xs x"

definition gSubstGVar2 where
"gSubstGVar2 MOD   ys y Y' Y.
   wls (asSort ys) Y'  gWls MOD (asSort ys) Y 
   gSubst MOD ys Y' Y y (Var ys y) (gVar MOD ys y) = Y"

definition gSubstGAbs where
"gSubstGAbs MOD   ys y Y' Y xs x s X' X.
   isInBar (xs,s) 
   wls (asSort ys) Y'  gWls MOD (asSort ys) Y 
   wls s X'  gWls MOD s X 
   (xs  ys  x  y)  fresh xs x Y'  gFresh MOD xs x Y' Y 
   gSubstAbs MOD ys Y' Y y (Abs xs x X') (gAbs MOD xs x X' X) =
   gAbs MOD xs x (X' #[Y' / y]_ys) (gSubst MOD ys Y' Y y X' X)"

definition gSubstGOp where
"gSubstGOp MOD   ys y Y' Y delta inp' inp binp' binp.
   wls (asSort ys) Y'  gWls MOD (asSort ys) Y 
   wlsInp delta inp'  gWlsInp MOD delta inp 
   wlsBinp delta binp'  gWlsBinp MOD delta binp 
   gSubst MOD ys Y' Y y (Op delta inp' binp') (gOp MOD delta inp' inp binp' binp) =
   gOp MOD delta
     (inp' %[Y' / y]_ys) (gSubstInp MOD ys Y' Y y inp' inp)
     (binp' %%[Y' / y]_ys) (gSubstBinp MOD ys Y' Y y binp' binp)"

definition gSubstCls where
"gSubstCls MOD  gSubstGVar1 MOD  gSubstGVar2 MOD  gSubstGAbs MOD  gSubstGOp MOD"

lemmas gSubstCls_defs = gSubstCls_def
gSubstGVar1_def gSubstGVar2_def gSubstGAbs_def gSubstGOp_def

(* Freshness-based congruence for abstractions: *)

(* ... employing swap: *)

definition gAbsCongS where
"gAbsCongS MOD   xs x x2 y s X' X X2' X2.
   isInBar (xs,s) 
   wls s X'  gWls MOD s X 
   wls s X2'  gWls MOD s X2 
   fresh xs y X'  gFresh MOD xs y X' X 
   fresh xs y X2'  gFresh MOD xs y X2' X2 
   (X' #[y  x]_xs) = (X2' #[y  x2]_xs) 
   gSwap MOD xs y x X' X = gSwap MOD xs y x2 X2' X2 
   gAbs MOD xs x X' X = gAbs MOD xs x2 X2' X2"

(* ... Note: no need for congruence employing subst (as it is not used in the
definition of rmorphisms *)

(* Abstraction renaming: *)

definition gAbsRen where
"gAbsRen MOD   xs y x s X' X.
    isInBar (xs,s)  wls s X'  gWls MOD s X 
    fresh xs y X'  gFresh MOD xs y X' X 
    gAbs MOD xs y (X' #[y // x]_xs) (gSubst MOD xs (Var xs y) (gVar MOD xs y) x X' X) =
    gAbs MOD xs x X' X"

text ‹Well-sorted fresh-swap models:›

definition wlsFSw where
"wlsFSw MOD  gWlsAllDisj MOD  gWlsAbsIsInBar MOD 
 gConsPresGWls MOD  gSwapAllPresGWlsAll MOD 
 gFreshCls MOD  gSwapCls MOD  gAbsCongS MOD"

lemmas wlsFSw_defs1 = wlsFSw_def
gWlsAllDisj_def gWlsAbsIsInBar_def
gConsPresGWls_def gSwapAllPresGWlsAll_def
gFreshCls_def gSwapCls_def gAbsCongS_def

lemmas wlsFSw_defs = wlsFSw_def
gWlsAllDisj_defs gWlsAbsIsInBar_def
gConsPresGWls_defs gSwapAllPresGWlsAll_defs
gFreshCls_defs gSwapCls_defs gAbsCongS_def

text ‹Well-sorted fresh-subst models:›

definition wlsFSb where
"wlsFSb MOD  gWlsAllDisj MOD  gWlsAbsIsInBar MOD 
 gConsPresGWls MOD  gSubstAllPresGWlsAll MOD 
 gFreshCls MOD  gSubstCls MOD  gAbsRen MOD"

lemmas wlsFSb_defs1 = wlsFSb_def
gWlsAllDisj_def gWlsAbsIsInBar_def
gConsPresGWls_def gSubstAllPresGWlsAll_def
gFreshCls_def gSubstCls_def gAbsRen_def

lemmas wlsFSb_defs = wlsFSb_def
gWlsAllDisj_defs gWlsAbsIsInBar_def
gConsPresGWls_defs gSubstAllPresGWlsAll_defs
gFreshCls_defs gSubstCls_defs gAbsRen_def

text ‹Well-sorted fresh-swap-subst-models›

definition wlsFSwSb where
"wlsFSwSb MOD  wlsFSw MOD  gSubstAllPresGWlsAll MOD  gSubstCls MOD"

lemmas wlsFSwSb_defs1 = wlsFSwSb_def
wlsFSw_def gSubstAllPresGWlsAll_def gSubstCls_def

lemmas wlsFSwSb_defs = wlsFSwSb_def
wlsFSw_def gSubstAllPresGWlsAll_defs gSubstCls_defs

text ‹Well-sorted fresh-subst-swap-models›

definition wlsFSbSw where
"wlsFSbSw MOD  wlsFSb MOD  gSwapAllPresGWlsAll MOD  gSwapCls MOD"

lemmas wlsFSbSw_defs1 = wlsFSbSw_def
wlsFSw_def gSwapAllPresGWlsAll_def gSwapCls_def

lemmas wlsFSbSw_defs = wlsFSbSw_def
wlsFSw_def gSwapAllPresGWlsAll_defs gSwapCls_defs

text‹Extension of domain preservation (by swap and subst) to inputs:›

text ‹First for free inputs:›

definition gSwapInpPresGWlsInp where
"gSwapInpPresGWlsInp MOD   zs z1 z2 delta inp' inp.
   wlsInp delta inp'  gWlsInp MOD delta inp 
   gWlsInp MOD delta (gSwapInp MOD zs z1 z2 inp' inp)"

definition gSubstInpPresGWlsInp where
"gSubstInpPresGWlsInp MOD   ys y Y' Y delta inp' inp.
   wls (asSort ys) Y'  gWls MOD (asSort ys) Y 
   wlsInp delta inp'  gWlsInp MOD delta inp 
   gWlsInp MOD delta (gSubstInp MOD ys Y' Y y inp' inp)"

lemma imp_gSwapInpPresGWlsInp:
"gSwapPresGWls MOD  gSwapInpPresGWlsInp MOD"
by (auto simp: lift2_def liftAll2_def sameDom_def wlsInp_iff gWlsInp_def 
gSwapPresGWls_def gSwapInpPresGWlsInp_def gSwapInp_def 
split: option.splits)

lemma imp_gSubstInpPresGWlsInp:
"gSubstPresGWls MOD  gSubstInpPresGWlsInp MOD"
by (auto simp: lift2_def liftAll2_def sameDom_def wlsInp_iff gWlsInp_def 
gSubstPresGWls_def gSubstInpPresGWlsInp_def gSubstInp_def 
split: option.splits)

text ‹Then for bound inputs:›

definition gSwapBinpPresGWlsBinp where
"gSwapBinpPresGWlsBinp MOD   zs z1 z2 delta binp' binp.
   wlsBinp delta binp'  gWlsBinp MOD delta binp 
   gWlsBinp MOD delta (gSwapBinp MOD zs z1 z2 binp' binp)"

definition gSubstBinpPresGWlsBinp where
"gSubstBinpPresGWlsBinp MOD   ys y Y' Y delta binp' binp.
   wls (asSort ys) Y'  gWls MOD (asSort ys) Y 
   wlsBinp delta binp'  gWlsBinp MOD delta binp 
   gWlsBinp MOD delta (gSubstBinp MOD ys Y' Y y binp' binp)"

lemma imp_gSwapBinpPresGWlsBinp:
"gSwapAbsPresGWlsAbs MOD  gSwapBinpPresGWlsBinp MOD"
by (auto simp: lift2_def liftAll2_def sameDom_def wlsBinp_iff gWlsBinp_def 
gSwapAbsPresGWlsAbs_def gSwapBinpPresGWlsBinp_def gSwapBinp_def 
split: option.splits)

lemma imp_gSubstBinpPresGWlsBinp:
"gSubstAbsPresGWlsAbs MOD  gSubstBinpPresGWlsBinp MOD" 
by (auto simp: lift2_def liftAll2_def sameDom_def wlsBinp_iff gWlsBinp_def 
gSubstAbsPresGWlsAbs_def gSubstBinpPresGWlsBinp_def gSubstBinp_def 
split: option.splits)
 
subsection‹Model morphisms from the term model›

definition presWls where
"presWls h MOD   s X. wls s X  gWls MOD s (h X)"

definition presWlsAbs where
"presWlsAbs hA MOD   us s A. wlsAbs (us,s) A  gWlsAbs MOD (us,s) (hA A)"

definition presWlsAll where
"presWlsAll h hA MOD  presWls h MOD  presWlsAbs hA MOD"

lemmas presWlsAll_defs = presWlsAll_def presWls_def presWlsAbs_def

definition presVar where
"presVar h MOD   xs x. h (Var xs x) = gVar MOD xs x"

definition presAbs where
"presAbs h hA MOD   xs x s X.
   isInBar (xs,s)  wls s X 
   hA (Abs xs x X) = gAbs MOD xs x X (h X)"

definition presOp where
"presOp h hA MOD   delta inp binp.
    wlsInp delta inp  wlsBinp delta binp 
    h (Op delta inp binp) =
    gOp MOD delta inp (lift h inp) binp (lift hA binp)"

definition presCons where
"presCons h hA MOD  presVar h MOD  presAbs h hA MOD  presOp h hA MOD"

lemmas presCons_defs = presCons_def
presVar_def presAbs_def presOp_def

definition presFresh where
"presFresh h MOD   ys y s X.
    wls s X 
    fresh ys y X  gFresh MOD ys y X (h X)"

definition presFreshAbs where
"presFreshAbs hA MOD   ys y us s A.
    wlsAbs (us,s) A 
    freshAbs ys y A  gFreshAbs MOD ys y A (hA A)"

definition presFreshAll where
"presFreshAll h hA MOD  presFresh h MOD  presFreshAbs hA MOD"

lemmas presFreshAll_defs = presFreshAll_def
presFresh_def presFreshAbs_def

definition presSwap where
"presSwap h MOD   zs z1 z2 s X.
    wls s X 
    h (X #[z1  z2]_zs) = gSwap MOD zs z1 z2 X (h X)"

definition presSwapAbs where
"presSwapAbs hA MOD   zs z1 z2 us s A.
    wlsAbs (us,s) A 
    hA (A $[z1  z2]_zs) = gSwapAbs MOD zs z1 z2 A (hA A)"

definition presSwapAll where
"presSwapAll h hA MOD  presSwap h MOD  presSwapAbs hA MOD"

lemmas presSwapAll_defs = presSwapAll_def
presSwap_def presSwapAbs_def

definition presSubst where
"presSubst h MOD   ys Y y s X.
    wls (asSort ys) Y  wls s X 
    h (subst ys Y y X) = gSubst MOD ys Y (h Y) y X (h X)"

definition presSubstAbs where
"presSubstAbs h hA MOD   ys Y y us s A.
    wls (asSort ys) Y  wlsAbs (us,s) A 
    hA (A $[Y / y]_ys) = gSubstAbs MOD ys Y (h Y) y A (hA A)"

definition presSubstAll where
"presSubstAll h hA MOD  presSubst h MOD  presSubstAbs h hA MOD"

lemmas presSubstAll_defs = presSubstAll_def
presSubst_def presSubstAbs_def

definition termFSwMorph where
"termFSwMorph h hA MOD  presWlsAll h hA MOD  presCons h hA MOD 
 presFreshAll h hA MOD  presSwapAll h hA MOD"

lemmas termFSwMorph_defs1 = termFSwMorph_def
presWlsAll_def presCons_def presFreshAll_def presSwapAll_def

lemmas termFSwMorph_defs = termFSwMorph_def
presWlsAll_defs presCons_defs presFreshAll_defs presSwapAll_defs

definition termFSbMorph where
"termFSbMorph h hA MOD  presWlsAll h hA MOD  presCons h hA MOD 
 presFreshAll h hA MOD  presSubstAll h hA MOD"

lemmas termFSbMorph_defs1 = termFSbMorph_def
presWlsAll_def presCons_def presFreshAll_def presSubstAll_def

lemmas termFSbMorph_defs = termFSbMorph_def
presWlsAll_defs presCons_defs presFreshAll_defs presSubstAll_defs

definition termFSwSbMorph where
"termFSwSbMorph h hA MOD  termFSwMorph h hA MOD  presSubstAll h hA MOD"

lemmas termFSwSbMorph_defs1 = termFSwSbMorph_def
termFSwMorph_def presSubstAll_def

lemmas termFSwSbMorph_defs = termFSwSbMorph_def
termFSwMorph_defs presSubstAll_defs

text‹Extension of domain preservation (by the morphisms) to inputs›

text‹. for free inputs:›

lemma presWls_wlsInp:
"wlsInp delta inp  presWls h MOD  gWlsInp MOD delta (lift h inp)"
by(auto simp: wlsInp_iff gWlsInp_def lift_def liftAll2_def sameDom_def 
presWls_def split: option.splits)
 

text‹. for bound inputs:›

lemma presWls_wlsBinp:
"wlsBinp delta binp  presWlsAbs hA MOD  gWlsBinp MOD delta (lift hA binp)"
by(auto simp: wlsBinp_iff gWlsBinp_def lift_def liftAll2_def sameDom_def 
presWlsAbs_def split: option.splits) 

subsection ‹From models to iterative models›

text ‹The transition map:›

definition fromMOD ::
"('index,'bindex,'varSort,'sort,'opSym,'var,'gTerm,'gAbs) model
 
 ('index,'bindex,'varSort,'sort,'opSym,'var,
  ('index,'bindex,'varSort,'var,'opSym)term × 'gTerm,
  ('index,'bindex,'varSort,'var,'opSym)abs × 'gAbs) Iteration.model"
where
"fromMOD MOD 
 
  igWls = λs X'X. wls s (fst X'X)  gWls MOD s (snd X'X),
  igWlsAbs = λus_s A'A. wlsAbs us_s (fst A'A)  gWlsAbs MOD us_s (snd A'A),

  igVar = λxs x. (Var xs x, gVar MOD xs x),
  igAbs = λxs x X'X. (Abs xs x (fst X'X), gAbs MOD xs x (fst X'X) (snd X'X)),
  igOp =
  λdelta iinp biinp.
    (Op delta (lift fst iinp) (lift fst biinp),
     gOp MOD delta
       (lift fst iinp) (lift snd iinp)
       (lift fst biinp) (lift snd biinp)),

  igFresh =
  λys y X'X. fresh ys y (fst X'X)  gFresh MOD ys y (fst X'X) (snd X'X),
  igFreshAbs =
  λys y A'A. freshAbs ys y (fst A'A)  gFreshAbs MOD ys y (fst A'A) (snd A'A),

  igSwap =
  λzs z1 z2 X'X. ((fst X'X) #[z1  z2]_zs, gSwap MOD zs z1 z2 (fst X'X) (snd X'X)),
  igSwapAbs =
  λzs z1 z2 A'A. ((fst A'A) $[z1  z2]_zs, gSwapAbs MOD zs z1 z2 (fst A'A) (snd A'A)),

  igSubst =
  λys Y'Y y X'X.
    ((fst X'X) #[(fst Y'Y) / y]_ys,
     gSubst MOD ys (fst Y'Y) (snd Y'Y) y (fst X'X) (snd X'X)),
  igSubstAbs =
  λys Y'Y y A'A.
    ((fst A'A) $[(fst Y'Y) / y]_ys,
     gSubstAbs MOD ys (fst Y'Y) (snd Y'Y) y (fst A'A) (snd A'A))
 "

text‹Basic simplification rules:›

lemma fromMOD_basic_simps[simp]:
"igWls (fromMOD MOD) s X'X =
 (wls s (fst X'X)  gWls MOD s (snd X'X))"
(*  *)
"igWlsAbs (fromMOD MOD) us_s A'A =
 (wlsAbs us_s (fst A'A)  gWlsAbs MOD us_s (snd A'A))"
(*  *)
"igVar (fromMOD MOD) xs x = (Var xs x, gVar MOD xs x)"
(*  *)
"igAbs (fromMOD MOD) xs x X'X = (Abs xs x (fst X'X), gAbs MOD xs x (fst X'X) (snd X'X))"
(*  *)
"igOp (fromMOD MOD) delta iinp biinp =
 (Op delta (lift fst iinp) (lift fst biinp),
  gOp MOD delta
    (lift fst iinp) (lift snd iinp)
    (lift fst biinp) (lift snd biinp))"
(*  *)
"igFresh (fromMOD MOD) ys y X'X =
 (fresh ys y (fst X'X)  gFresh MOD ys y (fst X'X) (snd X'X))"
(*  *)
"igFreshAbs (fromMOD MOD) ys y A'A  =
 (freshAbs ys y (fst A'A)  gFreshAbs MOD ys y (fst A'A) (snd A'A))"
(*  *)
"igSwap (fromMOD MOD) zs z1 z2 X'X =
 ((fst X'X) #[z1  z2]_zs, gSwap MOD zs z1 z2 (fst X'X) (snd X'X))"
(*  *)
"igSwapAbs (fromMOD MOD) zs z1 z2 A'A =
 ((fst A'A) $[z1  z2]_zs, gSwapAbs MOD zs z1 z2 (fst A'A) (snd A'A))"
(*  *)
"igSubst (fromMOD MOD) ys Y'Y y X'X =
 ((fst X'X) #[(fst Y'Y) / y]_ys,
  gSubst MOD ys (fst Y'Y) (snd Y'Y) y (fst X'X) (snd X'X))"
(*  *)
"igSubstAbs (fromMOD MOD) ys Y'Y y A'A =
 ((fst A'A) $[(fst Y'Y) / y]_ys,
  gSubstAbs MOD ys (fst Y'Y) (snd Y'Y) y (fst A'A) (snd A'A))"
unfolding fromMOD_def by auto

text‹Simps for inputs›

text‹. for free inputs:›

lemma igWlsInp_fromMOD[simp]:
"igWlsInp (fromMOD MOD) delta iinp 
 wlsInp delta (lift fst iinp)  gWlsInp MOD delta (lift snd iinp)"
apply (intro iffI)
 subgoal apply(simp add: liftAll2_def lift_def sameDom_def 
   igWlsInp_def wlsInp_iff gWlsInp_def split: option.splits) .
 subgoal 
   unfolding liftAll2_def lift_def sameDom_def 
   igWlsInp_def wlsInp_iff gWlsInp_def 
   by simp (metis (no_types, lifting) eq_snd_iff fstI option.case_eq_if 
       option.distinct(1) option.simps(5)) .

lemma igFreshInp_fromMOD[simp]:
"igFreshInp (fromMOD MOD) ys y iinp  
 freshInp ys y (lift fst iinp)  gFreshInp MOD ys y (lift fst iinp) (lift snd iinp)"
by (auto simp: igFreshInp_def gFreshInp_def freshInp_def
liftAll2_def liftAll_def lift_def split: option.splits)

lemma igSwapInp_fromMOD[simp]:
"igSwapInp (fromMOD MOD) zs z1 z2 iinp = 
 lift2 Pair
   (swapInp zs z1 z2 (lift fst iinp))
   (gSwapInp MOD zs z1 z2 (lift fst iinp) (lift snd iinp))"
by(auto simp: igSwapInp_def swapInp_def gSwapInp_def lift_def lift2_def
split: option.splits) 

lemma igSubstInp_fromMOD[simp]:
"igSubstInp (fromMOD MOD) ys Y'Y y iinp =
 lift2 Pair
   (substInp ys (fst Y'Y) y (lift fst iinp))
   (gSubstInp MOD ys (fst Y'Y) (snd Y'Y) y (lift fst iinp) (lift snd iinp))"
by(auto simp: igSubstInp_def substInp_def2 gSubstInp_def lift_def lift2_def
split: option.splits) 

lemmas input_fromMOD_simps =
igWlsInp_fromMOD igFreshInp_fromMOD igSwapInp_fromMOD igSubstInp_fromMOD

text‹. for bound inputs:›

lemma igWlsBinp_fromMOD[simp]:
"igWlsBinp (fromMOD MOD) delta biinp  
 (wlsBinp delta (lift fst biinp)  gWlsBinp MOD delta (lift snd biinp))"
apply (intro iffI)
 subgoal apply(simp add: liftAll2_def lift_def sameDom_def 
   igWlsBinp_def wlsBinp_iff gWlsBinp_def split: option.splits) .
 subgoal 
   unfolding liftAll2_def lift_def sameDom_def 
   igWlsBinp_def wlsBinp_iff gWlsBinp_def 
   by simp (metis (no_types, lifting) eq_snd_iff fstI option.case_eq_if 
       option.distinct(1) option.simps(5)) .

lemma igFreshBinp_fromMOD[simp]:
"igFreshBinp (fromMOD MOD) ys y biinp  
 (freshBinp ys y (lift fst biinp) 
  gFreshBinp MOD ys y (lift fst biinp) (lift snd biinp))"
by (auto simp: igFreshBinp_def gFreshBinp_def freshBinp_def
liftAll2_def liftAll_def lift_def split: option.splits)

lemma igSwapBinp_fromMOD[simp]:
"igSwapBinp (fromMOD MOD) zs z1 z2 biinp = 
 lift2 Pair
   (swapBinp zs z1 z2 (lift fst biinp))
   (gSwapBinp MOD zs z1 z2 (lift fst biinp) (lift snd biinp))"
by(auto simp: igSwapBinp_def swapBinp_def gSwapBinp_def lift_def lift2_def
split: option.splits) 

lemma igSubstBinp_fromMOD[simp]:
"igSubstBinp (fromMOD MOD) ys Y'Y y biinp =
 lift2 Pair
   (substBinp ys (fst Y'Y) y (lift fst biinp))
   (gSubstBinp MOD ys (fst Y'Y) (snd Y'Y) y (lift fst biinp) (lift snd biinp))"
by(auto simp: igSubstBinp_def substBinp_def2 gSubstBinp_def lift_def lift2_def
split: option.splits)

lemmas binput_fromMOD_simps =
igWlsBinp_fromMOD igFreshBinp_fromMOD igSwapBinp_fromMOD igSubstBinp_fromMOD

text‹Domain disjointness:›

lemma igWlsDisj_fromMOD[simp]:
"gWlsDisj MOD  igWlsDisj (fromMOD MOD)"
unfolding igWlsDisj_def gWlsDisj_def by auto

lemma igWlsAbsDisj_fromMOD[simp]:
"gWlsAbsDisj MOD  igWlsAbsDisj (fromMOD MOD)"
unfolding igWlsAbsDisj_def gWlsAbsDisj_def by fastforce

lemma igWlsAllDisj_fromMOD[simp]:
"gWlsAllDisj MOD  igWlsAllDisj (fromMOD MOD)"
unfolding igWlsAllDisj_def gWlsAllDisj_def by fastforce

lemmas igWlsAllDisj_fromMOD_simps =
igWlsDisj_fromMOD igWlsAbsDisj_fromMOD igWlsAllDisj_fromMOD

text‹Abstractions only within IsInBar:›

lemma igWlsAbsIsInBar_fromMOD[simp]:
"gWlsAbsIsInBar MOD  igWlsAbsIsInBar (fromMOD MOD)"
unfolding gWlsAbsIsInBar_def igWlsAbsIsInBar_def by simp

text‹The constructs preserve the domains:›

lemma igVarIPresIGWls_fromMOD[simp]:
"gVarPresGWls MOD  igVarIPresIGWls (fromMOD MOD)"
unfolding igVarIPresIGWls_def gVarPresGWls_def by simp

lemma igAbsIPresIGWls_fromMOD[simp]:
"gAbsPresGWls MOD  igAbsIPresIGWls (fromMOD MOD)"
unfolding igAbsIPresIGWls_def gAbsPresGWls_def by simp

lemma igOpIPresIGWls_fromMOD[simp]:
"gOpPresGWls MOD  igOpIPresIGWls (fromMOD MOD)"
unfolding igOpIPresIGWls_def gOpPresGWls_def by simp

lemma igConsIPresIGWls_fromMOD[simp]:
"gConsPresGWls MOD  igConsIPresIGWls (fromMOD MOD)"
unfolding igConsIPresIGWls_def gConsPresGWls_def by simp

lemmas igConsIPresIGWls_fromMOD_simps =
igVarIPresIGWls_fromMOD igAbsIPresIGWls_fromMOD
igOpIPresIGWls_fromMOD igConsIPresIGWls_fromMOD

text‹Swap preserves the domains:›

lemma igSwapIPresIGWls_fromMOD[simp]:
"gSwapPresGWls MOD  igSwapIPresIGWls (fromMOD MOD)"
unfolding igSwapIPresIGWls_def gSwapPresGWls_def by simp

lemma igSwapAbsIPresIGWlsAbs_fromMOD[simp]:
"gSwapAbsPresGWlsAbs MOD  igSwapAbsIPresIGWlsAbs (fromMOD MOD)"
unfolding igSwapAbsIPresIGWlsAbs_def gSwapAbsPresGWlsAbs_def by simp

lemma igSwapAllIPresIGWlsAll_fromMOD[simp]:
"gSwapAllPresGWlsAll MOD  igSwapAllIPresIGWlsAll (fromMOD MOD)"
unfolding igSwapAllIPresIGWlsAll_def gSwapAllPresGWlsAll_def by simp

lemmas igSwapAllIPresIGWlsAll_fromMOD_simps =
igSwapIPresIGWls_fromMOD igSwapAbsIPresIGWlsAbs_fromMOD igSwapAllIPresIGWlsAll_fromMOD

text‹Subst preserves the domains:›

lemma igSubstIPresIGWls_fromMOD[simp]:
"gSubstPresGWls MOD  igSubstIPresIGWls (fromMOD MOD)"
unfolding igSubstIPresIGWls_def gSubstPresGWls_def by simp

lemma igSubstAbsIPresIGWlsAbs_fromMOD[simp]:
"gSubstAbsPresGWlsAbs MOD  igSubstAbsIPresIGWlsAbs (fromMOD MOD)"
unfolding igSubstAbsIPresIGWlsAbs_def gSubstAbsPresGWlsAbs_def by simp

lemma igSubstAllIPresIGWlsAll_fromMOD[simp]:
"gSubstAllPresGWlsAll MOD  igSubstAllIPresIGWlsAll (fromMOD MOD)"
unfolding igSubstAllIPresIGWlsAll_def gSubstAllPresGWlsAll_def by simp

lemmas igSubstAllIPresIGWlsAll_fromMOD_simps =
igSubstIPresIGWls_fromMOD igSubstAbsIPresIGWlsAbs_fromMOD igSubstAllIPresIGWlsAll_fromMOD

text‹The fresh clauses:›

lemma igFreshIGVar_fromMOD[simp]:
"gFreshGVar MOD  igFreshIGVar (fromMOD MOD)"
unfolding igFreshIGVar_def gFreshGVar_def by simp

lemma igFreshIGAbs1_fromMOD[simp]:
"gFreshGAbs1 MOD  igFreshIGAbs1 (fromMOD MOD)"
unfolding igFreshIGAbs1_def gFreshGAbs1_def by auto

lemma igFreshIGAbs2_fromMOD[simp]:
"gFreshGAbs2 MOD  igFreshIGAbs2 (fromMOD MOD)"
unfolding igFreshIGAbs2_def gFreshGAbs2_def by auto

lemma igFreshIGOp_fromMOD[simp]:
"gFreshGOp MOD  igFreshIGOp (fromMOD MOD)"
unfolding igFreshIGOp_def gFreshGOp_def by simp

lemma igFreshCls_fromMOD[simp]:
"gFreshCls MOD  igFreshCls (fromMOD MOD)"
unfolding igFreshCls_def gFreshCls_def by simp

lemmas igFreshCls_fromMOD_simps =
igFreshIGVar_fromMOD igFreshIGAbs1_fromMOD igFreshIGAbs2_fromMOD
igFreshIGOp_fromMOD igFreshCls_fromMOD

text‹The swap clauses›

lemma igSwapIGVar_fromMOD[simp]:
"gSwapGVar MOD  igSwapIGVar (fromMOD MOD)"
unfolding igSwapIGVar_def gSwapGVar_def by simp

lemma igSwapIGAbs_fromMOD[simp]:
"gSwapGAbs MOD  igSwapIGAbs (fromMOD MOD)"
unfolding igSwapIGAbs_def gSwapGAbs_def by auto

lemma igSwapIGOp_fromMOD[simp]:
"gSwapGOp MOD  igSwapIGOp (fromMOD MOD)"
by (auto simp: igSwapIGOp_def gSwapGOp_def lift_lift2)

lemma igSwapCls_fromMOD[simp]:
"gSwapCls MOD  igSwapCls (fromMOD MOD)"
unfolding igSwapCls_def gSwapCls_def by simp

lemmas igSwapCls_fromMOD_simps =
igSwapIGVar_fromMOD igSwapIGAbs_fromMOD
igSwapIGOp_fromMOD igSwapCls_fromMOD

text‹The subst clauses›

lemma igSubstIGVar1_fromMOD[simp]:
"gSubstGVar1 MOD  igSubstIGVar1 (fromMOD MOD)"
unfolding igSubstIGVar1_def gSubstGVar1_def by simp

lemma igSubstIGVar2_fromMOD[simp]:
"gSubstGVar2 MOD  igSubstIGVar2 (fromMOD MOD)"
unfolding igSubstIGVar2_def gSubstGVar2_def by simp

lemma igSubstIGAbs_fromMOD[simp]:
"gSubstGAbs MOD  igSubstIGAbs (fromMOD MOD)"
unfolding igSubstIGAbs_def gSubstGAbs_def by fastforce+

lemma igSubstIGOp_fromMOD[simp]:
"gSubstGOp MOD  igSubstIGOp (fromMOD MOD)"
by(auto simp: igSubstIGOp_def gSubstGOp_def lift_lift2)

lemma igSubstCls_fromMOD[simp]:
"gSubstCls MOD  igSubstCls (fromMOD MOD)"
unfolding igSubstCls_def gSubstCls_def by simp

lemmas igSubstCls_fromMOD_simps =
igSubstIGVar1_fromMOD igSubstIGVar2_fromMOD igSubstIGAbs_fromMOD
igSubstIGOp_fromMOD igSubstCls_fromMOD

text‹Abstraction swapping congruence:›

lemma igAbsCongS_fromMOD[simp]:
assumes "gAbsCongS MOD"
shows "igAbsCongS (fromMOD MOD)"
using assms
unfolding igAbsCongS_def gAbsCongS_def 
apply simp  
apply clarify
by (intro conjI, erule wls_Abs_swap_cong) blast+

text‹Abstraction renaming:›

lemma igAbsRen_fromMOD[simp]:
"gAbsRen MOD  igAbsRen (fromMOD MOD)"
unfolding igAbsRen_def gAbsRen_def vsubst_def by auto

text‹Models:›

lemma iwlsFSw_fromMOD[simp]:
"wlsFSw MOD  iwlsFSw (fromMOD MOD)"
unfolding iwlsFSw_def wlsFSw_def by simp

lemma iwlsFSb_fromMOD[simp]:
"wlsFSb MOD  iwlsFSb (fromMOD MOD)"
unfolding iwlsFSb_def wlsFSb_def by simp

lemma iwlsFSwSb_fromMOD[simp]:
"wlsFSwSb MOD  iwlsFSwSb (fromMOD MOD)"
unfolding iwlsFSwSb_def wlsFSwSb_def by simp

lemma iwlsFSbSw_fromMOD[simp]:
"wlsFSbSw MOD  iwlsFSbSw (fromMOD MOD)"
unfolding iwlsFSbSw_def wlsFSbSw_def by simp

lemmas iwlsModel_fromMOD_simps =
iwlsFSw_fromMOD iwlsFSb_fromMOD
iwlsFSwSb_fromMOD iwlsFSbSw_fromMOD

(******************************)
lemmas fromMOD_predicate_simps =
igWlsAllDisj_fromMOD_simps
igConsIPresIGWls_fromMOD_simps
igSwapAllIPresIGWlsAll_fromMOD_simps
igSubstAllIPresIGWlsAll_fromMOD_simps
igFreshCls_fromMOD_simps
igSwapCls_fromMOD_simps
igSubstCls_fromMOD_simps
igAbsCongS_fromMOD
igAbsRen_fromMOD
iwlsModel_fromMOD_simps

lemmas fromMOD_simps =
fromMOD_basic_simps
input_fromMOD_simps
binput_fromMOD_simps
fromMOD_predicate_simps

subsection ‹The recursion-iteration ``identity trick"›

text ‹Here we show that any construct-preserving map from terms to ``fromMOD MOD"
is the identity on its first projection -- this is the main trick when
reducing recursion to iteration.›

lemma ipresCons_fromMOD_fst:
assumes "ipresCons h hA (fromMOD MOD)"
shows "(wls s X  fst (h X) = X)  (wlsAbs (us,s') A  fst (hA A) = A)"
proof(induction rule: wls_rawInduct) 
next
  case (Op delta inp binp) 
  hence "lift (fst  h) inp = inp  lift (fst  hA) binp = binp"
  by (simp add: lift_def fun_eq_iff liftAll2_def 
   wlsInp_iff wlsBinp_iff sameDom_def split: option.splits) 
  (metis not_Some_eq old.prod.exhaust) 
  then show ?case
  using assms Op by (auto simp: ipresCons_def ipresOp_def lift_comp)
qed(insert assms, auto simp: ipresVar_def ipresCons_def ipresAbs_def)

lemma ipresCons_fromMOD_fst_simps[simp]:
"ipresCons h hA (fromMOD MOD); wls s X
  fst (h X) = X"
(*  *)
"ipresCons h hA (fromMOD MOD); wlsAbs (us,s') A
  fst (hA A) = A"
using ipresCons_fromMOD_fst by blast+

lemma ipresCons_fromMOD_fst_inp[simp]:
"ipresCons h hA (fromMOD MOD)  wlsInp delta inp  lift (fst o h) inp = inp"
by (force simp add: lift_def fun_eq_iff liftAll2_def 
wlsInp_iff sameDom_def split: option.splits)
 

lemma ipresCons_fromMOD_fst_binp[simp]:
"ipresCons h hA (fromMOD MOD)  wlsBinp delta binp  lift (fst o hA) binp = binp"
by (force simp add: lift_def fun_eq_iff liftAll2_def 
wlsBinp_iff sameDom_def split: option.splits)

lemmas ipresCons_fromMOD_fst_all_simps =
ipresCons_fromMOD_fst_simps ipresCons_fromMOD_fst_inp ipresCons_fromMOD_fst_binp

subsection ‹From iteration morphisms to morphisms›

text‹The transition map:›

definition fromIMor ::
"(('index,'bindex,'varSort,'var,'opSym)term 
  ('index,'bindex,'varSort,'var,'opSym)term × 'gTerm)
 
 (('index,'bindex,'varSort,'var,'opSym)term  'gTerm)"
where "fromIMor h  snd o h"

definition fromIMorAbs ::
"(('index,'bindex,'varSort,'var,'opSym)abs 
  ('index,'bindex,'varSort,'var,'opSym)abs × 'gAbs)
 
 (('index,'bindex,'varSort,'var,'opSym)abs  'gAbs)"
where "fromIMorAbs hA  snd o hA"

text‹Basic simplification rules:›

lemma fromIMor[simp]: "fromIMor h X' = snd (h X')"
unfolding fromIMor_def by simp

lemma fromIMorAbs[simp]: "fromIMorAbs hA A' = snd (hA A')"
unfolding fromIMorAbs_def by simp

lemma fromIMor_snd_inp[simp]:
"wlsInp delta inp  lift (fromIMor h) inp = lift (snd o h) inp"
by (auto simp: lift_def split: option.splits)

lemma fromIMorAbs_snd_binp[simp]:
"wlsBinp delta binp  lift (fromIMorAbs hA) binp = lift (snd o hA) binp"
by (auto simp: lift_def split: option.splits)

lemmas fromIMor_basic_simps =
fromIMor fromIMorAbs fromIMor_snd_inp fromIMorAbs_snd_binp

text‹Predicate simplification rules›

text‹Domain preservation›

lemma presWls_fromIMor[simp]:
"ipresWls h (fromMOD MOD)  presWls (fromIMor h) MOD"
unfolding ipresWls_def presWls_def by simp

lemma presWlsAbs_fromIMorAbs[simp]:
"ipresWlsAbs hA (fromMOD MOD)  presWlsAbs (fromIMorAbs hA) MOD"
unfolding ipresWlsAbs_def presWlsAbs_def by simp

lemma presWlsAll_fromIMorAll[simp]:
"ipresWlsAll h hA (fromMOD MOD)  presWlsAll (fromIMor h) (fromIMorAbs hA) MOD"
unfolding ipresWlsAll_def presWlsAll_def by simp

lemmas presWlsAll_fromIMorAll_simps =
presWls_fromIMor presWlsAbs_fromIMorAbs presWlsAll_fromIMorAll

text‹Preservation of the constructs›

lemma presVar_fromIMor[simp]:
"ipresCons h hA (fromMOD MOD)  presVar (fromIMor h) MOD"
unfolding ipresCons_def ipresVar_def presVar_def by simp

lemma presAbs_fromIMor[simp]:
assumes "ipresCons h hA (fromMOD MOD)"
shows "presAbs (fromIMor h) (fromIMorAbs hA) MOD"
using assms unfolding ipresCons_def ipresAbs_def presAbs_def
using assms by fastforce

lemma presOp_fromIMor[simp]:
assumes "ipresCons h hA (fromMOD MOD)"
shows "presOp (fromIMor h) (fromIMorAbs hA) MOD"
using assms unfolding ipresCons_def ipresOp_def presOp_def
using assms by (auto simp: lift_comp)

lemma presCons_fromIMor[simp]:
assumes "ipresCons h hA (fromMOD MOD)"
shows "presCons (fromIMor h) (fromIMorAbs hA) MOD"
unfolding ipresCons_def presCons_def using assms by simp

lemmas presCons_fromIMor_simps =
presVar_fromIMor presAbs_fromIMor presOp_fromIMor presCons_fromIMor

text‹Preservation of freshness›

lemma presFresh_fromIMor[simp]:
"ipresCons h hA (fromMOD MOD)  ipresFresh h (fromMOD MOD)
  presFresh (fromIMor h) MOD"
unfolding ipresFresh_def presFresh_def by simp

lemma presFreshAbs_fromIMor[simp]:
"ipresCons h hA (fromMOD MOD)  ipresFreshAbs hA (fromMOD MOD) 
  presFreshAbs (fromIMorAbs hA) MOD"
unfolding ipresFreshAbs_def presFreshAbs_def by simp

lemma presFreshAll_fromIMor[simp]:
"ipresCons h hA (fromMOD MOD)  ipresFreshAll h hA (fromMOD MOD) 
  presFreshAll (fromIMor h) (fromIMorAbs hA) MOD"

unfolding ipresFreshAll_def presFreshAll_def by simp

lemmas presFreshAll_fromIMor_simps =
presFresh_fromIMor presFreshAbs_fromIMor presFreshAll_fromIMor

text‹Preservation of swap›

lemma presSwap_fromIMor[simp]:
"ipresCons h hA (fromMOD MOD)  ipresSwap h (fromMOD MOD) 
  presSwap (fromIMor h) MOD"
unfolding ipresSwap_def presSwap_def by simp

lemma presSwapAbs_fromIMor[simp]:
"ipresCons h hA (fromMOD MOD)  ipresSwapAbs hA (fromMOD MOD) 
  presSwapAbs (fromIMorAbs hA) MOD"
unfolding ipresSwapAbs_def presSwapAbs_def by simp

lemma presSwapAll_fromIMor[simp]:
"ipresCons h hA (fromMOD MOD)  ipresSwapAll h hA (fromMOD MOD)
  presSwapAll (fromIMor h) (fromIMorAbs hA) MOD"
unfolding ipresSwapAll_def presSwapAll_def by simp

lemmas presSwapAll_fromIMor_simps =
presSwap_fromIMor presSwapAbs_fromIMor presSwapAll_fromIMor

text‹Preservation of subst›

lemma presSubst_fromIMor[simp]:
"ipresCons h hA (fromMOD MOD)  ipresSubst h (fromMOD MOD)
  presSubst (fromIMor h) MOD"
unfolding ipresSubst_def presSubst_def by auto

lemma presSubstAbs_fromIMor[simp]:
"ipresCons h hA (fromMOD MOD)  ipresSubstAbs h hA (fromMOD MOD) 
  presSubstAbs (fromIMor h) (fromIMorAbs hA) MOD"
unfolding ipresSubstAbs_def presSubstAbs_def by auto

lemma presSubstAll_fromIMor[simp]:
"ipresCons h hA (fromMOD MOD)  ipresSubstAll h hA (fromMOD MOD) 
  presSubstAll (fromIMor h) (fromIMorAbs hA) MOD"
unfolding ipresSubstAll_def presSubstAll_def by simp

lemmas presSubstAll_fromIMor_simps =
presSubst_fromIMor presSubstAbs_fromIMor presSubstAll_fromIMor

text‹Morphisms›

lemma fromIMor_termFSwMorph[simp]:
"termFSwImorph h hA (fromMOD MOD)  termFSwMorph (fromIMor h) (fromIMorAbs hA) MOD"
unfolding termFSwImorph_def termFSwMorph_def by simp

lemma fromIMor_termFSbMorph[simp]:
"termFSbImorph h hA (fromMOD MOD)  termFSbMorph (fromIMor h) (fromIMorAbs hA) MOD"
unfolding termFSbImorph_def termFSbMorph_def by simp

lemma fromIMor_termFSwSbMorph[simp]:
assumes "termFSwSbImorph h hA (fromMOD MOD)"
shows "termFSwSbMorph (fromIMor h) (fromIMorAbs hA) MOD"
using assms unfolding termFSwSbImorph_defs1
using assms unfolding termFSwSbImorph_def termFSwSbMorph_def by simp

lemmas mor_fromIMor_simps =
fromIMor_termFSwMorph fromIMor_termFSbMorph fromIMor_termFSwSbMorph

(********************************)
lemmas fromIMor_predicate_simps =
presCons_fromIMor_simps
presFreshAll_fromIMor_simps
presSwapAll_fromIMor_simps
presSubstAll_fromIMor_simps
mor_fromIMor_simps

lemmas fromIMor_simps =
fromIMor_basic_simps fromIMor_predicate_simps

subsection ‹The recursion theorem›

text‹The recursion maps:›

definition rec where "rec MOD  fromIMor (iter (fromMOD MOD))"

definition recAbs where "recAbs MOD  fromIMorAbs (iterAbs (fromMOD MOD))"

text‹Existence:›

theorem wlsFSw_recAll_termFSwMorph:
"wlsFSw MOD  termFSwMorph (rec MOD) (recAbs MOD) MOD"
by (simp add: rec_def recAbs_def iwlsFSw_iterAll_termFSwImorph)   

theorem wlsFSb_recAll_termFSbMorph:
"wlsFSb MOD  termFSbMorph (rec MOD) (recAbs MOD) MOD"
by (simp add: rec_def recAbs_def iwlsFSb_iterAll_termFSbImorph)

theorem wlsFSwSb_recAll_termFSwSbMorph:
"wlsFSwSb MOD  termFSwSbMorph (rec MOD) (recAbs MOD) MOD"
by (simp add: rec_def recAbs_def iwlsFSwSb_iterAll_termFSwSbImorph) 

theorem wlsFSbSw_recAll_termFSwSbMorph:
"wlsFSbSw MOD  termFSwSbMorph (rec MOD) (recAbs MOD) MOD"
by (simp add: rec_def recAbs_def iwlsFSbSw_iterAll_termFSwSbImorph) 


text‹Uniqueness:›

lemma presCons_unique:
assumes "presCons f fA MOD" and "presCons g gA MOD"
shows "(wls s X  f X = g X)  (wlsAbs (us,s') A  fA A = gA A)"
proof(induction rule: wls_rawInduct)
  case (Op delta inp binp)
  hence "lift f inp = lift g inp  lift fA binp = lift gA binp" 
  apply(simp add: lift_def wlsInp_iff wlsBinp_iff sameDom_def liftAll2_def fun_eq_iff split: option.splits)
  by (metis not_Some_eq old.prod.exhaust)
  then show ?case using assms Op unfolding presCons_def presOp_def by simp
qed(insert assms, auto simp: presVar_def presCons_def presAbs_def )

theorem wlsFSw_recAll_unique_presCons:
assumes "wlsFSw MOD" and "presCons h hA MOD"
shows "(wls s X  h X = rec MOD X)  
       (wlsAbs (us,s') A  hA A = recAbs MOD A)"
using assms wlsFSw_recAll_termFSwMorph 
by (intro presCons_unique) (auto simp: termFSwMorph_def)

theorem wlsFSb_recAll_unique_presCons:
assumes "wlsFSb MOD" and "presCons h hA MOD"
shows "(wls s X  h X = rec MOD X) 
       (wlsAbs (us,s') A  hA A = recAbs MOD A)"
using assms wlsFSb_recAll_termFSbMorph 
by (intro presCons_unique) (auto simp: termFSbMorph_def) 

theorem wlsFSwSb_recAll_unique_presCons:
assumes "wlsFSwSb MOD" and "presCons h hA MOD"
shows "(wls s X  h X = rec MOD X) 
       (wlsAbs (us,s') A  hA A = recAbs MOD A)"
using assms wlsFSw_recAll_unique_presCons unfolding wlsFSwSb_def by blast

theorem wlsFSbSw_recAll_unique_presCons:
assumes "wlsFSbSw MOD" and "presCons h hA MOD"
shows "(wls s X  h X = rec MOD X) 
      (wlsAbs (us,s') A  hA A = recAbs MOD A)"
using assms wlsFSb_recAll_unique_presCons unfolding wlsFSbSw_def by blast

subsection‹Models that are even ``closer" to the term model›

text‹We describe various conditions (later referred to as ``extra clauses"
or ``extra conditions")
that, when satisfied by models,
yield the recursive maps
(1) freshness-preserving and/or (2) injective and/or (3) surjective, thus bringing the
considered models ``closer" to (being isomorphic to) the term model.
The extreme case, when all of (1)-(3) above are ensured, means indeed isomorphism to
the term model -- this is in fact an abstract characterization of the term model.›

subsubsection ‹Relevant predicates on models›

text‹The fresh clauses reversed›

definition gFreshGVarRev where
"gFreshGVarRev MOD   xs y x.
   gFresh MOD xs y (Var xs x) (gVar MOD xs x)  y  x"

definition gFreshGAbsRev where
"gFreshGAbsRev MOD   ys y xs x s X' X.
   isInBar (xs,s)  wls s X'  gWls MOD s X 
   gFreshAbs MOD ys y (Abs xs x X') (gAbs MOD xs x X' X) 
   (ys = xs  y = x)  gFresh MOD ys y X' X"

definition gFreshGOpRev where
"gFreshGOpRev MOD   ys y delta inp' inp binp' binp.
   wlsInp delta inp'  gWlsInp MOD delta inp  wlsBinp delta binp'  gWlsBinp MOD delta binp 
   gFresh MOD ys y (Op delta inp' binp') (gOp MOD delta inp' inp binp' binp) 
   gFreshInp MOD ys y inp' inp  gFreshBinp MOD ys y binp' binp"

definition gFreshClsRev where
"gFreshClsRev MOD  gFreshGVarRev MOD  gFreshGAbsRev MOD  gFreshGOpRev MOD"

lemmas gFreshClsRev_defs = gFreshClsRev_def
gFreshGVarRev_def gFreshGAbsRev_def gFreshGOpRev_def

text‹Injectiveness of the construct operators›

definition gVarInj where
"gVarInj MOD   xs x y. gVar MOD xs x = gVar MOD xs y  x = y"

definition gAbsInj where
"gAbsInj MOD   xs s x X' X X1' X1.
   isInBar (xs,s)  wls s X'  gWls MOD s X  wls s X1'  gWls MOD s X1 
   gAbs MOD xs x X' X = gAbs MOD xs x X1' X1
   
   X = X1"

definition gOpInj where
"gOpInj MOD   delta delta1 inp' binp' inp binp inp1' binp1' inp1 binp1.
   wlsInp delta inp'  wlsBinp delta binp'  gWlsInp MOD delta inp  gWlsBinp MOD delta binp 
   wlsInp delta1 inp1'  wlsBinp delta1 binp1'  gWlsInp MOD delta1 inp1  gWlsBinp MOD delta1 binp1 
   stOf delta = stOf delta1 
   gOp MOD delta inp' inp binp' binp = gOp MOD delta1 inp1' inp1 binp1' binp1
   
   delta = delta1  inp = inp1  binp = binp1"

definition gVarGOpInj where
"gVarGOpInj MOD   xs x delta inp' binp' inp binp.
   wlsInp delta inp'  wlsBinp delta binp'  gWlsInp MOD delta inp  gWlsBinp MOD delta binp 
   asSort xs = stOf delta
   
   gVar MOD xs x  gOp MOD delta inp' inp binp' binp"

definition gConsInj where
"gConsInj MOD  gVarInj MOD  gAbsInj MOD  gOpInj MOD  gVarGOpInj MOD"

lemmas gConsInj_defs = gConsInj_def
gVarInj_def gAbsInj_def gOpInj_def gVarGOpInj_def

text‹Abstraction renaming for swapping›

definition gAbsRenS where
"gAbsRenS MOD   xs y x s X' X.
    isInBar (xs,s)  wls s X'  gWls MOD s X 
    fresh xs y X'  gFresh MOD xs y X' X 
    gAbs MOD xs y (X' #[y  x]_xs) (gSwap MOD xs y x X' X) =
    gAbs MOD xs x X' X"

text‹Indifference to the general-recursive argument›

text‹. This ``indifference" property says that the construct operators
from the model only depend on
the generalized item (i.e., generalized term or abstraction) argument,
and {\em not} on the ``item" (i.e., concrete term or abstraction) argument.
In other words, the model constructs correspond to {\em iterative clauses},
and not to the more general notion of ``general-recursive" clause.›

definition gAbsIndif where
"gAbsIndif MOD   xs s x X1' X2' X.
    isInBar (xs,s)  wls s X1'  wls s X2'  gWls MOD s X 
    gAbs MOD xs x X1' X = gAbs MOD xs x X2' X"

definition gOpIndif where
"gOpIndif MOD   delta inp1' inp2' inp binp1' binp2' binp.
   wlsInp delta inp1'  wlsBinp delta binp1'  wlsInp delta inp2'  wlsBinp delta binp2' 
   gWlsInp MOD delta inp  gWlsBinp MOD delta binp
   
   gOp MOD delta inp1' inp binp1' binp = gOp MOD delta inp2' inp binp2' binp"

definition gConsIndif where
"gConsIndif MOD  gOpIndif MOD  gAbsIndif MOD"

lemmas gConsIndif_defs = gConsIndif_def gAbsIndif_def gOpIndif_def

text‹Inductiveness›

text‹. Inductiveness of a model means the satisfaction of a minimal inductive
principle (``minimal" in the sense that no fancy swapping or freshness
induction-friendly conditions are involved).›

definition gInduct where
"gInduct MOD   phi phiAbs s X us s' A.
   (
    ( xs x. phi (asSort xs) (gVar MOD xs x))
    
    ( delta inp' inp binp' binp.
       wlsInp delta inp'  wlsBinp delta binp'  gWlsInp MOD delta inp  gWlsBinp MOD delta binp 
       liftAll2 phi (arOf delta) inp  liftAll2 phiAbs (barOf delta) binp
        phi (stOf delta) (gOp MOD delta inp' inp binp' binp))
    
    ( xs s x X' X.
        isInBar (xs,s)  wls s X'  gWls MOD s X 
        phi s X
         phiAbs (xs,s) (gAbs MOD xs x X' X))
   )
   
   (gWls MOD s X  phi s X) 
   (gWlsAbs MOD (us,s') A  phiAbs (us,s') A)"

lemma gInduct_elim:
assumes "gInduct MOD" and
Var: " xs x. phi (asSort xs) (gVar MOD xs x)" and
Op:
" delta inp' inp binp' binp.
    wlsInp delta inp'; wlsBinp delta binp'; gWlsInp MOD delta inp; gWlsBinp MOD delta binp;
     liftAll2 phi (arOf delta) inp; liftAll2 phiAbs (barOf delta) binp
     phi (stOf delta) (gOp MOD delta inp' inp binp' binp)" and
Abs:
" xs s x X' X.
   isInBar (xs,s); wls s X'; gWls MOD s X; phi s X
    phiAbs (xs,s) (gAbs MOD xs x X' X)"
shows
"(gWls MOD s X  phi s X) 
 (gWlsAbs MOD (us,s') A  phiAbs (us,s') A)"
using assms unfolding gInduct_def
apply(elim allE[of _ phi] allE[of _ phiAbs] allE[of _ s] allE[of _ X]) 
apply(elim allE[of _ us] allE[of _ s'] allE[of _ A])
by blast

subsubsection ‹Relevant predicates on maps from the term model›

text‹Reflection of freshness›

definition reflFresh where
"reflFresh h MOD   ys y s X.
   wls s X 
   gFresh MOD ys y X (h X)  fresh ys y X"

definition reflFreshAbs where
"reflFreshAbs hA MOD   ys y us s A.
   wlsAbs (us,s) A 
   gFreshAbs MOD ys y A (hA A)  freshAbs ys y A"

definition reflFreshAll where
"reflFreshAll h hA MOD  reflFresh h MOD  reflFreshAbs hA MOD"

lemmas reflFreshAll_defs = reflFreshAll_def
reflFresh_def reflFreshAbs_def

text‹Injectiveness›

definition isInj where
"isInj h   s X Y.
   wls s X  wls s Y 
   h X = h Y  X = Y"

definition isInjAbs where
"isInjAbs hA   us s A B.
   wlsAbs (us,s) A  wlsAbs (us,s) B 
   hA A = hA B  A = B"

definition isInjAll where
"isInjAll h hA  isInj h  isInjAbs hA"

lemmas isInjAll_defs = isInjAll_def
isInj_def isInjAbs_def

text‹Surjectiveness›

definition isSurj where
"isSurj h MOD   s X.
   gWls MOD s X 
   ( X'. wls s X'  h X' = X)"

definition isSurjAbs where
"isSurjAbs hA MOD   us s A.
   gWlsAbs MOD (us,s) A 
   ( A'. wlsAbs (us,s) A'  hA A' = A)"

definition isSurjAll where
"isSurjAll h hA MOD  isSurj h MOD  isSurjAbs hA MOD"

lemmas isSurjAll_defs = isSurjAll_def
isSurj_def isSurjAbs_def

subsubsection‹Criterion for the reflection of freshness›

text‹First an auxiliary fact, independent of the type of model:›

lemma gFreshClsRev_recAll_reflFreshAll:
assumes pWls: "presWlsAll (rec MOD) (recAbs MOD) MOD"
and pCons: "presCons (rec MOD) (recAbs MOD) MOD"
and pFresh: "presFreshAll (rec MOD) (recAbs MOD) MOD"
and **: "gFreshClsRev MOD"
shows "reflFreshAll (rec MOD) (recAbs MOD) MOD"
proof-
  let ?h = "rec MOD"   let ?hA = "recAbs MOD"
  have pWlsInps[simp]:
  " delta inp. wlsInp delta inp  gWlsInp MOD delta (lift ?h inp)"
  " delta binp. wlsBinp delta binp  gWlsBinp MOD delta (lift ?hA binp)"
  using pWls presWls_wlsInp presWls_wlsBinp unfolding presWlsAll_def by auto
  {fix ys y s X us s' A
   have
   "(wls s X  gFresh MOD ys y X (rec MOD X)  fresh ys y X) 
    (wlsAbs (us,s') A  gFreshAbs MOD ys y A (recAbs MOD A)  freshAbs ys y A)"
   proof(induction rule: wls_induct)
     case (Var xs x)
     then show ?case using assms 
     by (fastforce simp: presWlsAll_defs presCons_defs gFreshClsRev_def gFreshGVarRev_def)
   next
     case (Op delta inp binp)
     show ?case proof safe
       let ?ar = "arOf delta"   let ?bar = "barOf delta"  let ?st = "stOf delta" 
     let ?linp = "lift ?h inp"  let ?lbinp = "lift ?hA binp"
     assume "gFresh MOD ys y (Op delta inp binp) (rec MOD (Op delta inp binp))"
     hence "gFresh MOD ys y (Op delta inp binp) (gOp MOD delta inp ?linp binp ?lbinp)" 
     using assms Op by (simp add: presCons_def presOp_def)
     hence "gFreshInp MOD ys y inp ?linp  gFreshBinp MOD ys y binp ?lbinp"
     using Op **  by (force simp:  gFreshClsRev_def gFreshGOpRev_def)
     with Op have freshInp: "freshInp ys y inp  freshBinp ys y binp"     
     by (simp add: freshInp_def freshBinp_def liftAll_def gFreshInp_def gFreshBinp_def liftAll2_def lift_def 
     sameDom_def wlsInp_iff wlsBinp_iff split: option.splits) (metis eq_snd_iff not_Some_eq) 
     thus "fresh ys y (Op delta inp binp)" using Op by auto
   qed
 next
   case (Abs s xs x X)
   show ?case proof safe  
     have hX: "gWls MOD s (?h X)" using Abs pWls unfolding presWlsAll_defs by simp
     assume "gFreshAbs MOD ys y (Abs xs x X) (recAbs MOD (Abs xs x X))" 
     hence "gFreshAbs MOD ys y (Abs xs x X) (gAbs MOD xs x X (rec MOD X))" 
     using Abs by (metis pCons presAbs_def presCons_def)
     moreover have "?hA (Abs xs x X) = gAbs MOD xs x X (?h X)"
     using Abs pCons unfolding presCons_defs by blast
     ultimately have 1: "gFreshAbs MOD ys y (Abs xs x X) (gAbs MOD xs x X (?h X))" by simp
     show "freshAbs ys y (Abs xs x X)"
     using assms hX Abs ** unfolding gFreshClsRev_def gFreshGAbsRev_def using 1 by fastforce
   qed
  qed
  }
  thus ?thesis unfolding reflFreshAll_defs by blast
qed
 
text‹For fresh-swap models›

theorem wlsFSw_recAll_reflFreshAll:
"wlsFSw MOD  gFreshClsRev MOD  reflFreshAll (rec MOD) (recAbs MOD) MOD"
using wlsFSw_recAll_termFSwMorph 
by (auto simp: termFSwMorph_def intro: gFreshClsRev_recAll_reflFreshAll)

text‹For fresh-subst models›

theorem wlsFSb_recAll_reflFreshAll:
"wlsFSb MOD  gFreshClsRev MOD  reflFreshAll (rec MOD) (recAbs MOD) MOD"
using wlsFSb_recAll_termFSbMorph 
by (auto simp: termFSbMorph_def intro: gFreshClsRev_recAll_reflFreshAll)
 

(* Note: Here and below: No need for corresponding results for FSwSb and FSbSw models, as they
would follow at once from the above. *)

subsubsection‹Criterion for the injectiveness of the recursive map›

text‹For fresh-swap models›

theorem wlsFSw_recAll_isInjAll:
assumes *: "wlsFSw MOD"  "gAbsRenS MOD" and **: "gConsInj MOD"
shows "isInjAll (rec MOD) (recAbs MOD)"
proof-
  let ?h = "rec MOD"   let ?hA = "recAbs MOD"
  have 1: "termFSwMorph ?h ?hA MOD" using * wlsFSw_recAll_termFSwMorph by auto
  hence pWls: "presWlsAll ?h ?hA MOD"
  and pCons: "presCons ?h ?hA MOD"
  and pFresh: "presFreshAll ?h ?hA MOD"
  and pSwap: "presSwapAll ?h ?hA MOD" unfolding termFSwMorph_def by auto
  hence pWlsInps[simp]:
  " delta inp. wlsInp delta inp  gWlsInp MOD delta (lift ?h inp)"
  " delta binp. wlsBinp delta binp  gWlsBinp MOD delta (lift ?hA binp)"
  using presWls_wlsInp presWls_wlsBinp unfolding presWlsAll_def by auto
  {fix s X us s' A
   have
   "(wls s X  ( Y. wls s Y  rec MOD X = rec MOD Y  X = Y)) 
    (wlsAbs (us,s') A  ( B. wlsAbs (us,s') B  recAbs MOD A = recAbs MOD B  A = B))"
   proof (induction rule: wls_induct) 
     case (Var xs x)
     show ?case proof clarify
       fix Y
       assume eq: "rec MOD (Var xs x) = rec MOD Y" and Y: "wls (asSort xs) Y"
       thus "Var xs x = Y" 
       proof-
         {fix ys y assume Y_def: "Y = Var ys y" and "asSort ys = asSort xs"
          hence ys_def: "ys = xs" by simp
          have rec_y_def: "rec MOD (Var ys y) = gVar MOD ys y"
          using pCons unfolding presCons_defs by simp
          have ?thesis
          using eq ** 1 unfolding Y_def rec_y_def gConsInj_def gVarInj_def
          unfolding ys_def by (simp add: termFSwMorph_defs)
         }
         moreover
         {fix delta1 inp1 binp1 assume inp1s: "wlsInp delta1 inp1"  "wlsBinp delta1 binp1"
          and Y_def: "Y = Op delta1 inp1 binp1" and st: "stOf delta1 = asSort xs"
          hence rec_Op_def:
          "rec MOD (Op delta1 inp1 binp1) =
           gOp MOD delta1 inp1 (lift ?h inp1) binp1 (lift ?hA binp1)"
          using pCons unfolding presCons_defs by simp
          have ?thesis
          using eq ** unfolding Y_def rec_Op_def gConsInj_def gVarGOpInj_def
          using inp1s st 1 by (simp add: termFSwMorph_defs)
         }
         ultimately show ?thesis using wls_nchotomy[of "asSort xs" Y] Y by blast
       qed 
     qed   
   next
     case (Op delta inp binp)
     show ?case proof clarify
       fix Y assume Y: "wls (stOf delta) Y"
       and "rec MOD (Op delta inp binp) = rec MOD Y"
       hence eq: "gOp MOD delta inp (lift ?h inp) binp (lift ?hA binp) = ?h Y"
       using 1 Op by (simp add: termFSwMorph_defs)
       show "Op delta inp binp = Y"
       proof-
         {fix ys y assume Y_def: "Y = Var ys y" and st: "asSort ys = stOf delta"
          have rec_y_def: "rec MOD (Var ys y) = gVar MOD ys y"
          using pCons unfolding presCons_defs by simp
          have ?thesis
          using eq[THEN sym] ** unfolding Y_def rec_y_def gConsInj_def gVarGOpInj_def
          using Op st by simp
         }
         moreover
         {fix delta1 inp1 binp1 assume inp1s: "wlsInp delta1 inp1"  "wlsBinp delta1 binp1"
          and Y_def: "Y = Op delta1 inp1 binp1" and st: "stOf delta1 = stOf delta"
          hence rec_Op_def:
          "rec MOD (Op delta1 inp1 binp1) =
           gOp MOD delta1 inp1 (lift ?h inp1) binp1 (lift ?hA binp1)"
          using pCons unfolding presCons_defs by simp
          have 0: "delta = delta1  lift ?h inp = lift ?h inp1  lift ?hA binp = lift ?hA binp1"
          using eq ** unfolding Y_def rec_Op_def gConsInj_def gOpInj_def
          using Op inp1s st apply clarify
          apply(erule allE[of _ delta])  apply(erule allE[of _ delta1]) by force
          hence delta1_def: "delta1 = delta" by simp
          have 1: "inp = inp1"   
          proof(rule ext)
            fix i
            show "inp i = inp1 i"  
            proof(cases "inp i")
              case None
              hence "lift ?h inp i = None" by(simp add: lift_None)
              hence "lift ?h inp1 i = None" using 0 by simp
              thus ?thesis unfolding None by(simp add: lift_None)
            next
              case (Some X) 
              hence "lift ?h inp i = Some (?h X)" unfolding lift_def by simp
              hence "lift ?h inp1 i = Some (?h X)" using 0 by simp
              then obtain Y where inp1_i: "inp1 i = Some Y" and hXY: "?h X = ?h Y"
              unfolding lift_def by(cases "inp1 i") auto
              then obtain s where ar_i: "arOf delta i = Some s"
              using inp1s unfolding delta1_def wlsInp_iff sameDom_def 
              by (cases "arOf delta i") auto
              hence Y: "wls s Y"
              using inp1s inp1_i unfolding delta1_def wlsInp_iff liftAll2_def by auto
              thus ?thesis 
              unfolding Some inp1_i using ar_i Some hXY Op.IH unfolding liftAll2_def by auto
            qed
          qed
          have 2: "binp = binp1"
          proof(rule ext)
            fix i
            show "binp i = binp1 i"
            proof(cases "binp i")
              case None
              hence "lift ?hA binp i = None" by(simp add: lift_None)
              hence "lift ?hA binp1 i = None" using 0 by simp
              thus ?thesis unfolding None by (simp add: lift_None)
            next
              case (Some A)
              hence "lift ?hA binp i = Some (?hA A)" unfolding lift_def by simp
              hence "lift ?hA binp1 i = Some (?hA A)" using 0 by simp
              then obtain B where binp1_i: "binp1 i = Some B" and hAB: "?hA A = ?hA B"
              unfolding lift_def by (cases "binp1 i") auto
              then obtain us s where bar_i: "barOf delta i = Some (us,s)"
              using inp1s unfolding delta1_def wlsBinp_iff sameDom_def
              by(cases "barOf delta i") auto
              hence B: "wlsAbs (us,s) B"
              using inp1s binp1_i unfolding delta1_def wlsBinp_iff liftAll2_def by auto
              thus ?thesis unfolding Some binp1_i  
              using bar_i Some hAB Op.IH unfolding liftAll2_def by fastforce
            qed
          qed
          have ?thesis unfolding Y_def delta1_def 1 2 by simp
         }
         ultimately show ?thesis using wls_nchotomy[of "stOf delta" Y] Y by blast
       qed
     qed
   next
     case (Abs s xs x X)
     show ?case proof clarify
       fix B
       assume B: "wlsAbs (xs,s) B" and "recAbs MOD (Abs xs x X) = recAbs MOD B"
       hence eq: "gAbs MOD xs x X (rec MOD X) = ?hA B" using 1 Abs by (simp add: termFSwMorph_defs)
       hence hX: "gWls MOD s (?h X)" using pWls Abs unfolding presWlsAll_defs by simp
       show "Abs xs x X = B"
       proof-
         let ?P = "ParS
          (λ xs'. [])
          (λ s'. if s' = s then [X] else [])
          (λ us_s. [])
          []"
         have P: "wlsPar ?P" using Abs unfolding wlsPar_def by simp
         {fix y Y assume Y: "wls s Y" and B_def: "B = Abs xs y Y"
          hence hY: "gWls MOD s (?h Y)" using pWls unfolding presWlsAll_defs by simp
          let ?Xsw = "X #[y  x]_xs" let ?hXsw = "gSwap MOD xs y x X (?h X)"
          have hXsw: "gWls MOD s ?hXsw"
          using Abs hX using * unfolding wlsFSw_def gSwapAllPresGWlsAll_defs by simp
          assume " s.  Y  termsOfS ?P s. fresh xs y Y"
          hence y_fresh: "fresh xs y X" by simp
          hence "gFresh MOD xs y X (?h X)"
          using Abs pFresh unfolding presFreshAll_defs by simp
          hence "gAbs MOD xs y (?Xsw) ?hXsw = gAbs MOD xs x X (?h X)"
          using Abs hX y_fresh * unfolding gAbsRenS_def by fastforce 
          also have " = ?hA B" using eq . 
          also have "recAbs MOD B = gAbs MOD xs y Y (?h Y)"          
          unfolding B_def using pCons Abs Y unfolding presCons_defs by blast 
          finally have "gAbs MOD xs y ?Xsw ?hXsw = gAbs MOD xs y Y (?h Y)" .
          hence "?hXsw = ?h Y"
          using ** Abs hX hXsw Y hY unfolding gConsInj_def gAbsInj_def
          apply clarify apply(erule allE[of _ xs]) apply(erule allE[of _ s])
          apply(erule allE[of _ y]) apply(erule allE[of _ ?Xsw]) by fastforce
          moreover have "?hXsw = ?h ?Xsw"
          using Abs pSwap unfolding presSwapAll_defs by simp
          ultimately have "?h ?Xsw = ?h Y" by simp
          moreover have "(X,?Xsw)  swapped" using swap_swapped .
          ultimately have Y_def: "Y = ?Xsw" using Y Abs.IH by auto
          have ?thesis unfolding B_def Y_def
          using Abs y_fresh by simp
         }
         thus ?thesis using B P wlsAbs_fresh_nchotomy[of xs s B] by blast
       qed
     qed
   qed
  }
  thus ?thesis unfolding isInjAll_defs by blast
qed


text‹For fresh-subst models›

theorem wlsFSb_recAll_isInjAll:
assumes *: "wlsFSb MOD" and **: "gConsInj MOD"
shows "isInjAll (rec MOD) (recAbs MOD)"
proof-
  let ?h = "rec MOD"   let ?hA = "recAbs MOD"
  have 1: "termFSbMorph ?h ?hA MOD" using * wlsFSb_recAll_termFSbMorph by auto
  hence pWls: "presWlsAll ?h ?hA MOD"
  and pCons: "presCons ?h ?hA MOD"
  and pFresh: "presFreshAll ?h ?hA MOD"
  and pSubst: "presSubstAll ?h ?hA MOD" unfolding termFSbMorph_def by auto
  hence pWlsInps[simp]:
  " delta inp. wlsInp delta inp  gWlsInp MOD delta (lift ?h inp)"
  " delta binp. wlsBinp delta binp  gWlsBinp MOD delta (lift ?hA binp)"
  using presWls_wlsInp presWls_wlsBinp unfolding presWlsAll_def by auto
  {fix s X us s' A
   have
   "(wls s X  ( Y. wls s Y  rec MOD X = rec MOD Y  X = Y)) 
    (wlsAbs (us,s') A  ( B. wlsAbs (us,s') B  recAbs MOD A = recAbs MOD B  A = B))"
   proof(induction rule: wls_induct)
     case (Var xs x)
     show ?case proof clarify
       fix Y
       assume "rec MOD (Var xs x) = rec MOD Y" and Y: "wls (asSort xs) Y"
       hence eq: "gVar MOD xs x = rec MOD Y" using 1 by (simp add: termFSbMorph_defs)
       show "Var xs x = Y"
       proof-
         {fix ys y assume Y_def: "Y = Var ys y" and "asSort ys = asSort xs"
          hence ys_def: "ys = xs" by simp
          have rec_y_def: "rec MOD (Var ys y) = gVar MOD ys y"
          using pCons unfolding presCons_defs by simp
          have ?thesis
          using eq ** unfolding Y_def rec_y_def gConsInj_def gVarInj_def
          unfolding ys_def by simp
         }
         moreover
         {fix delta1 inp1 binp1 assume inp1s: "wlsInp delta1 inp1"  "wlsBinp delta1 binp1"
          and Y_def: "Y = Op delta1 inp1 binp1" and st: "stOf delta1 = asSort xs"
          hence rec_Op_def:
          "rec MOD (Op delta1 inp1 binp1) =
           gOp MOD delta1 inp1 (lift ?h inp1) binp1 (lift ?hA binp1)"
          using pCons unfolding presCons_defs by simp
          have ?thesis
          using eq ** unfolding Y_def rec_Op_def gConsInj_def gVarGOpInj_def
          using inp1s st by simp
         }
         ultimately show ?thesis using wls_nchotomy[of "asSort xs" Y] Y by blast
       qed
     qed
   next
     case (Op delta inp binp)
     show ?case proof clarify
       fix Y
       assume  "rec MOD (Op delta inp binp) = rec MOD Y" and Y: "wls (stOf delta) Y"
       hence eq: "gOp MOD delta inp (lift ?h inp) binp (lift ?hA binp) = ?h Y"
       using Op 1 by (simp add: termFSbMorph_defs)
       show "Op delta inp binp = Y"
       proof-
         {fix ys y assume Y_def: "Y = Var ys y" and st: "asSort ys = stOf delta"
          have rec_y_def: "rec MOD (Var ys y) = gVar MOD ys y"
          using pCons unfolding presCons_defs by simp
          have ?thesis
          using eq[THEN sym] ** unfolding Y_def rec_y_def gConsInj_def gVarGOpInj_def
          using Op st by simp
         }
         moreover
         {fix delta1 inp1 binp1 assume inp1s: "wlsInp delta1 inp1"  "wlsBinp delta1 binp1"
          and Y_def: "Y = Op delta1 inp1 binp1" and st: "stOf delta1 = stOf delta"
          hence rec_Op_def:
          "rec MOD (Op delta1 inp1 binp1) =
           gOp MOD delta1 inp1 (lift ?h inp1) binp1 (lift ?hA binp1)"
          using pCons unfolding presCons_defs by simp
          have 0: "delta = delta1  lift ?h inp = lift ?h inp1  lift ?hA binp = lift ?hA binp1"
          using eq ** unfolding Y_def rec_Op_def gConsInj_def gOpInj_def
          using Op inp1s st apply clarify
          apply(erule allE[of _ delta])  apply(erule allE[of _ delta1]) by force
          hence delta1_def: "delta1 = delta" by simp
          have 1: "inp = inp1"
          proof(rule ext)
            fix i
            show "inp i = inp1 i"
            proof(cases "inp i")
              case None
              hence "lift ?h inp i = None" by(simp add: lift_None)
              hence "lift ?h inp1 i = None" using 0 by simp
              thus ?thesis unfolding None by(simp add: lift_None)
            next
              case (Some X)
              hence "lift ?h inp i = Some (?h X)" unfolding lift_def by simp
              hence "lift ?h inp1 i = Some (?h X)" using 0 by simp
              then obtain Y where inp1_i: "inp1 i = Some Y" and hXY: "?h X = ?h Y"
              unfolding lift_def by (cases "inp1 i") auto
              then obtain s where ar_i: "arOf delta i = Some s"
              using inp1s unfolding delta1_def wlsInp_iff sameDom_def
              by (cases "arOf delta i") auto
              hence Y: "wls s Y"
              using inp1s inp1_i unfolding delta1_def wlsInp_iff liftAll2_def by auto
              thus ?thesis unfolding Some inp1_i  
              using ar_i Some hXY Op.IH unfolding liftAll2_def by auto
            qed
          qed
          have 2: "binp = binp1"
          proof(rule ext)
            fix i
            show "binp i = binp1 i"
            proof(cases "binp i")
              case None
              hence "lift ?hA binp i = None" by(simp add: lift_None)
              hence "lift ?hA binp1 i = None" using 0 by simp
              thus ?thesis unfolding None by(simp add: lift_None)
            next
              case (Some A)
              hence "lift ?hA binp i = Some (?hA A)" unfolding lift_def by simp
              hence "lift ?hA binp1 i = Some (?hA A)" using 0 by simp
              then obtain B where binp1_i: "binp1 i = Some B" and hAB: "?hA A = ?hA B"
              unfolding lift_def by(cases "binp1 i", auto)
              then obtain us s where bar_i: "barOf delta i = Some (us,s)"
              using inp1s unfolding delta1_def wlsBinp_iff sameDom_def
              by(cases "barOf delta i") auto
              hence B: "wlsAbs (us,s) B"
              using inp1s binp1_i unfolding delta1_def wlsBinp_iff liftAll2_def by auto
              thus ?thesis unfolding Some binp1_i 
              using bar_i Some hAB Op.IH
              unfolding liftAll2_def by fastforce
            qed
          qed
          have ?thesis unfolding Y_def delta1_def 1 2 by simp
         }
         ultimately show ?thesis using wls_nchotomy[of "stOf delta" Y] Y by blast
       qed
     qed
   next
     case (Abs s xs x X)
     show ?case proof clarify
       fix B
       assume B: "wlsAbs (xs,s) B" and "recAbs MOD (Abs xs x X) = recAbs MOD B"
       hence eq: "gAbs MOD xs x X (rec MOD X) = ?hA B" 
       using 1 Abs by (simp add: termFSbMorph_defs)
       hence hX: "gWls MOD s (?h X)" using pWls Abs unfolding presWlsAll_defs by simp
       show "Abs xs x X = B"
       proof-
         let ?P = "ParS
          (λ xs'. [])
          (λ s'. if s' = s then [X] else [])
          (λ us_s. [])
          []"
         have P: "wlsPar ?P" using Abs unfolding wlsPar_def by simp
         {fix y Y assume Y: "wls s Y" and B_def: "B = Abs xs y Y"
          hence hY: "gWls MOD s (?h Y)" using pWls unfolding presWlsAll_defs by simp
          let ?Xsb = "X #[y // x]_xs"
          let ?hXsb = "gSubst MOD xs (Var xs y) (gVar MOD xs y) x X (?h X)"
          have 1: "wls (asSort xs) (Var xs y)  gWls MOD (asSort xs) (gVar MOD xs y)"
          using * unfolding wlsFSb_def gConsPresGWls_defs by simp
          hence hXsb: "gWls MOD s ?hXsb"
          using Abs hX using * unfolding wlsFSb_def gSubstAllPresGWlsAll_defs by simp
          assume " s.  Y  termsOfS ?P s. fresh xs y Y"
          hence y_fresh: "fresh xs y X" by simp
          hence "gFresh MOD xs y X (?h X)"
          using Abs pFresh unfolding presFreshAll_defs by simp
          hence "gAbs MOD xs y (?Xsb) ?hXsb = gAbs MOD xs x X (?h X)"
          using Abs hX y_fresh * unfolding wlsFSb_def gAbsRen_def by fastforce
          also have " = ?hA B" using eq .
          also have " = gAbs MOD xs y Y (?h Y)"
          unfolding B_def using pCons Abs Y unfolding presCons_defs by blast
          finally have
          "gAbs MOD xs y ?Xsb ?hXsb = gAbs MOD xs y Y (?h Y)" .
          hence "?hXsb = ?h Y"
          using ** Abs hX hXsb Y hY unfolding gConsInj_def gAbsInj_def
          apply clarify apply(erule allE[of _ xs]) apply(erule allE[of _ s])
          apply(erule allE[of _ y]) apply(erule allE[of _ ?Xsb]) by fastforce
          moreover have "?hXsb = ?h ?Xsb"
          using Abs pSubst 1 pCons unfolding presSubstAll_defs vsubst_def presCons_defs by simp
          ultimately have "?h ?Xsb = ?h Y" by simp
          hence Y_def: "Y = ?Xsb" using Y Abs.IH by (fastforce simp add: termFSbMorph_defs)
          have ?thesis unfolding B_def Y_def
          using Abs y_fresh by simp
         }
         thus ?thesis using B P wlsAbs_fresh_nchotomy[of xs s B] by blast
       qed
     qed
   qed 
  }
  thus ?thesis unfolding isInjAll_defs by blast
qed

subsubsection‹Criterion for the surjectiveness of the recursive map›

text‹First an auxiliary fact, independent of the type of model:›

lemma gInduct_gConsIndif_recAll_isSurjAll:
assumes pWls: "presWlsAll (rec MOD) (recAbs MOD) MOD"
and pCons: "presCons (rec MOD) (recAbs MOD) MOD"
and "gConsIndif MOD" and *: "gInduct MOD"
shows "isSurjAll (rec MOD) (recAbs MOD) MOD"
proof-
  let ?h = "rec MOD"   let ?hA = "recAbs MOD"
  {fix s X us s' A
   from * have
   "(gWls MOD s X  ( X'. wls s X'  rec MOD X' = X)) 
    (gWlsAbs MOD (us,s') A  ( A'. wlsAbs (us,s') A'  recAbs MOD A' = A))"
   proof (elim gInduct_elim, safe)
     fix xs x
     show "X'. wls (asSort xs) X'  rec MOD X' = gVar MOD xs x"
     using pWls pCons 
     by (auto simp: presWlsAll_defs presCons_defs intro: exI[of _ "Var xs x"]) 
   next
     fix delta inp' inp binp' binp
     let ?ar = "arOf delta"   let ?bar = "barOf delta"  let ?st = "stOf delta"
     assume inp': "wlsInp delta inp'" and binp': "wlsBinp delta binp'"
     and inp: "gWlsInp MOD delta inp" and binp: "gWlsBinp MOD delta binp"
     and IH: "liftAll2 (λs X. X'. wls s X'  ?h X' = X) ?ar inp"
     and BIH: "liftAll2 (λus_s A. A'. wlsAbs us_s A'  ?hA A' = A) ?bar binp"
     (*  *)
     let ?phi = "λ s X X'. wls s X'  ?h X' = X"
     obtain inp1' where inp1'_def:
     "inp1' =
      (λ i.
         case (?ar i, inp i) of
           (None, None)  None
          |(Some s, Some X)  Some (SOME X'. ?phi s X X'))" by blast
     hence [simp]:
     " i. ?ar i = None  inp i = None  inp1' i = None"
     " i s X. ?ar i = Some s  inp i = Some X  inp1' i = Some (SOME X'. ?phi s X X')"
     unfolding inp1'_def by auto
     have inp1': "wlsInp delta inp1'"
     unfolding wlsInp_iff proof safe
       show "sameDom ?ar inp1'"
       unfolding sameDom_def proof clarify
         fix i
         have "(?ar i = None) = (inp i = None)"
         using inp unfolding gWlsInp_def sameDom_def by simp
         thus "(?ar i = None) = (inp1' i = None)"
         unfolding inp1'_def by auto
       qed
     next
       show "liftAll2 wls ?ar inp1'"
       unfolding liftAll2_def proof auto
         fix i s X1'
         assume ari: "?ar i = Some s" and inp1'i: "inp1' i = Some X1'"
         have "sameDom inp ?ar"
         using inp unfolding gWlsInp_def using sameDom_sym by blast
         then obtain X where inpi: "inp i = Some X"
         using ari unfolding sameDom_def by(cases "inp i") auto
         hence X1'_def: "X1' = (SOME X1'. ?phi s X X1')"
         using ari inp1'i unfolding inp1'_def by simp
         obtain X' where X': "?phi s X X'"
         using inpi ari IH unfolding liftAll2_def by blast
         hence "?phi s X X1'"
         unfolding X1'_def by(rule someI[of "?phi s X"])
         thus "wls s X1'" by simp
       qed
     qed(insert binp' wlsBinp.cases, blast)
     (* *)
     have lift_inp1': "lift ?h inp1' = inp"
     proof(rule ext)
       fix i let ?linp1' = "lift ?h inp1'"
       show "?linp1' i = inp i"
       proof(cases "inp i")
         case None
         hence "?ar i = None" using inp unfolding gWlsInp_def sameDom_def by simp
         hence "inp1' i = None" using None by simp 
         thus "lift (rec MOD) inp1' i = inp i" using None by (auto simp: lift_def)
       next
         case (Some X)
         then obtain s where ari: "?ar i = Some s"
         using inp unfolding gWlsInp_def sameDom_def by(cases "?ar i") auto
         let ?X1' = "SOME X1'. ?phi s X X1'"
         have inp1'i: "inp1' i = Some ?X1'" using ari Some by simp
         hence linp1'i: "?linp1' i = Some (?h ?X1')" unfolding lift_def by simp
         obtain X' where X': "?phi s X X'"
         using Some ari IH unfolding liftAll2_def by blast
         hence "?phi s X ?X1'" by(rule someI[of "?phi s X"])
         thus "lift (rec MOD) inp1' i = inp i" using Some linp1'i by (auto simp: lift_def)
       qed
     qed
     (*  *)
     let ?bphi = "λ (us,s) A A'. wlsAbs (us,s) A'  ?hA A' = A"
     obtain binp1' where binp1'_def:
     "binp1' =
      (λ i.
         case (?bar i, binp i) of
           (None, None)  None
          |(Some (us,s), Some A)  Some (SOME A'. ?bphi (us,s) A A'))" by blast
     hence [simp]:
     " i. ?bar i = None  binp i = None  binp1' i = None"
     and *:
     " i us s A. ?bar i = Some (us,s)  binp i = Some A 
        binp1' i = Some (SOME A'. ?bphi (us,s) A A')"
     unfolding binp1'_def by auto
     have binp1': "wlsBinp delta binp1'"
     unfolding wlsBinp_iff proof safe
       show "sameDom ?bar binp1'"
       unfolding sameDom_def proof clarify
         fix i
         have "(?bar i = None) = (binp i = None)"
         using binp unfolding gWlsBinp_def sameDom_def by simp
         thus "(?bar i = None) = (binp1' i = None)"
         unfolding binp1'_def by auto
       qed
     next
       show "liftAll2 wlsAbs ?bar binp1'"
       unfolding liftAll2_def proof auto
         fix i us s A1'
         assume bari: "?bar i = Some (us,s)" and binp1'i: "binp1' i = Some A1'"
         have "sameDom binp ?bar"
         using binp unfolding gWlsBinp_def using sameDom_sym by blast
         then obtain A where binpi: "binp i = Some A"
         using bari unfolding sameDom_def by(cases "binp i", auto)
         hence A1'_def: "A1' = (SOME A1'. ?bphi (us,s) A A1')"
         using bari binp1'i unfolding binp1'_def by simp
         obtain A' where A': "?bphi (us,s) A A'"
         using binpi bari BIH unfolding liftAll2_def by fastforce
         hence "?bphi (us,s) A A1'"
         unfolding A1'_def by(rule someI[of "?bphi (us,s) A"])
         thus "wlsAbs (us,s) A1'" by simp
       qed    
     qed(insert binp' wlsBinp.cases, blast)
     (* *)
     have lift_binp1': "lift ?hA binp1' = binp"
     proof(rule ext)
       fix i let ?lbinp1' = "lift ?hA binp1'"
       show "?lbinp1' i = binp i"
       proof(cases "binp i")
         case None
         hence "?bar i = None" using binp unfolding gWlsBinp_def sameDom_def by simp
         hence "binp1' i = None" using None by simp
         thus "lift (recAbs MOD) binp1' i = binp i" using None by (simp add: lift_def)
       next
         case (Some A)
         then obtain us s where bari: "?bar i = Some (us,s)"
         using binp unfolding gWlsBinp_def sameDom_def by(cases "?bar i", auto)
         let ?A1' = "SOME A1'. ?bphi (us,s) A A1'"
         have binp1'i: "binp1' i = Some ?A1'" using bari Some *[of i us s A] by simp
         hence lbinp1'i: "?lbinp1' i = Some (?hA ?A1')" unfolding lift_def by simp
         obtain A' where A': "?bphi (us,s) A A'"
         using Some bari BIH unfolding liftAll2_def by fastforce
         hence "?bphi (us,s) A ?A1'" by(rule someI[of "?bphi (us,s) A"])
         thus "lift (recAbs MOD) binp1' i = binp i" using Some lbinp1'i by simp
       qed
     qed
     (*  *)
     let ?X' = "Op delta inp1' binp1'"
     have X': "wls ?st ?X'" using inp1' binp1' by simp
     have "?h ?X' = gOp MOD delta inp1' inp binp1' binp"
     using inp1' binp1' pCons lift_inp1' lift_binp1'
     unfolding presCons_defs by simp
     hence "?h ?X' = gOp MOD delta inp' inp binp' binp"
     using inp' inp1' inp binp' binp1' binp assms
     unfolding gConsIndif_defs by metis
     thus "X'. wls (stOf delta) X'  ?h X' = gOp MOD delta inp' inp binp' binp"
     using X' by blast
   next
     fix xs s x X' X1'
     assume xs_s: "isInBar (xs,s)" and X': "wls s X'" and
     hX1': "gWls MOD s (?h X1')" and X1': "wls s X1'"
     thus "A'. wlsAbs (xs,s) A'  ?hA A' = gAbs MOD xs x X' (?h X1')"
     apply(intro exI[of _ "Abs xs x X1'"])  
     using pCons unfolding presCons_def presAbs_def apply safe 
     apply(elim allE[of _ xs]) apply(elim allE[of _ x]) apply(elim allE[of _ s]) 
     apply simp_all   
     using assms unfolding gConsIndif_defs by blast
   qed
  }
  thus ?thesis unfolding isSurjAll_defs by blast
qed

text‹For fresh-swap models›

theorem wlsFSw_recAll_isSurjAll:
"wlsFSw MOD  gConsIndif MOD  gInduct MOD
  isSurjAll (rec MOD) (recAbs MOD) MOD"
using wlsFSw_recAll_termFSwMorph 
by (auto simp: termFSwMorph_def intro: gInduct_gConsIndif_recAll_isSurjAll)

text‹For fresh-subst models›

theorem wlsFSb_recAll_isSurjAll:
"wlsFSb MOD  gConsIndif MOD  gInduct MOD
  isSurjAll (rec MOD) (recAbs MOD) MOD"
using wlsFSb_recAll_termFSbMorph 
by (auto simp: termFSbMorph_def intro: gInduct_gConsIndif_recAll_isSurjAll)

(********************************************)
lemmas recursion_simps =
fromMOD_simps ipresCons_fromMOD_fst_all_simps fromIMor_simps

declare recursion_simps [simp del]

end (* context FixSyn *)
(************************************************)

end